aribas165b/0000755000076600000240000000000014660574013011574 5ustar ottostaffaribas165b/CHANGES165.txt0000644000076600000240000001004114660571636013645 0ustar ottostaffFile CHANGES.TXT ARIBAS interpreter for Arithmetic, V1.65b, August 2024 Copyright (C) O.Forster 1996-2018 WWW: http://www.mathematik.uni-muenchen.de/~forster Changes from former versions of ARIBAS to the present version: V 1.65b (Aug. 2024) - minor corrections in function addsarr (file aritools.c) V 1.65 (Sep. 2018) - elimininated some bugs and compiler warnings (detected by D. Trebbien) V 1.64 (Jan. 2010) - bug fix in trigonometric functions with high floating point precision - raised maximal floating point precision to 5120 bits V 1.60 to 1.63 (Feb. 2008) - bug fix in open_write - corrected behavior of function round - fixed bug occuring in some gf2n_ and gf2X_ function on bigendian architectures - bug fix in function gf2X_mod V 1.50 to 1.60 (Aug. 2007) - direct support for polynomial arithmetic over GF(2), functions gf2X_mult, gf2X_square, gf2X_divide, gf2X_div, gf2X_mod, gf2X_gcd, gf2X_modpower, gf2X_primetest - bug fix in handling of -pi (previous version changed constant pi) - bug fix in division of integer vectors with negative coefficients - for loop can now handle >= 2**32 iterations - fixed bug which occurred in V 1.50 while parsing certain parenthized expressions V 1.40 to V1.50 (Aug. 2004) - direct support for GF(2**n); data type gf2nint, functions gf2n_init, gf2n_fieldpol, gf2n_degree, gf2n_trace, max_gf2nsize - new function gfp_sqrt - removed a bug in integer division - new function ec_factorize - improved performance of qs_factorize (less unsuccessfull factorizations, thanks to Lew Baxter for testing) V1.30 (March 2002) to V1.40 (June 2003) - simultaneous assignments (x1,x2,...,xn) := (a1,a2,...,an) - new functions divide, bit_count, set_workdir, get_workdir, gmtime, stack2string, stack_arraypush, string_scan, realloc, binsearch - some bug fixes (regarding qs_factorize and handling of special variable and value arguments in user defined functions) V1.20b (June 2001) to V1.30 (March 2002) - vector operations: vec + vec, lambda * vec, vec * lambda, intvec mod N, intvec div N, gcd(intvec) - some small bugfixes - fixed bug occuring in special situations when reading comments V1.14 (April 1999) to V1.20b (June 2001) - flush(transcript) - floating point precision can be set up to 4096 bits (over 1200 decimal places); former limit was 192 bits - bugfix in function mem_byteswap() - make_unbound(user) unbinds all user defined functions - new function max_intsize(); returns maximal number of decimal places of an integer V1.08b (Nov. 1997) to V1.14 (April 1999) - since V1.13 there is now a (preliminary) version of ARIBAS for MS-Windows 95/98/NT - function load in UNIX versions of ARIBAS now accepts also .ari files with DOS line endings - silent version of functions rho_factorize, cf_factorize, qs_factorize, next_prime with last argument 0. - new builtin function next_prime next_prime(x) calculates the smallest prime p >= x - new builtin function qs_factorize (factorization with quadratic sieve method, faster than cf_factorize; on a Pentium PC 233MHz, the seventh Fermat numbers is factorized in a few seconds) - continue statement in for and while loops (works as in C) V1.07 (April 1997) to V1.08b (Nov. 1997) - fixed bug in factorial(n) for n=0,1 - readln() can now read big integers which extend over several lines - new command line option -b (batch mode): aribas -b tt.scr starts ARIBAS, loads file "tt.scr" which is supposed to contain ARIBAS code, executes it, and then exits. V1.00 (Sep. 1996) to V1.07 (April 1997) - new functions version() and max_arraysize() - function protocol() renamed to transcript() - new command line options -h (help path) and -p (ari path) - (versions for 80[3-5]86 processor) small speedup in big integer arithmetic - (MSDOS version) changed memory management for function system() - bugfix in function random() (************************** EOF ******************************) aribas165b/doc/0000755000076600000240000000000014660570652012346 5ustar ottostaffaribas165b/doc/aribas.10000644000076600000240000004215714660570651013701 0ustar ottostaff.\" Licensed under the Gnu Public License, Version 2 .\" .\" $Id: ssystem.1.2 1996/06/30 13:33:54 bousch Exp $ .\" .TH ARIBAS 1 "February 2001" "ARIBAS" .SH NAME aribas \- Multiprecision Arithmetic Interpreter .SH SYNOPSIS .B aribas [\fIoptions\fR] [<\fIari-file\fR> [<\fIarg1\fR> <\fIarg2\fR> ...]] This man page was written for Debian since the orginal software did not contain a man page. .SH DESCRIPTION \fBAribas\fR is an interactive interpreter suitable for big integer arithmetic and multiprecision floating point arithmetic. It has a syntax similar to Pascal or Modula-2, but contains also features from other programming languages like C, Lisp, Oberon. .\"--------------------------------------------------------- .SH USAGE The simplest way to use \fBaribas\fR is as a calculator for (big integer) arithmetic. After \fBaribas\fR is started, it displays a prompt .BR ==> and is ready to accept input. Simply enter the expression you want to calculate, followed by a full stop, and then press RETURN, for example .nf ==> 123 + 456*789. .fi \fBAribas\fR answers .nf -: 359907 .fi The symbol \fB-:\fR introduces the result. .br .BR IMPORTANT. To mark the end of your input, you must always type a full stop `.' and then press RETURN. .br .PP You can assign the result of a calculation to a variable, as in .nf ==> F6 := 2**64 + 1. -: 18446_74407_37095_51617 .fi This calculates the 6th Fermat number (\fB**\fR denotes exponentiation) and assigns it to the variable \fBF6\fR (note that \fBaribas\fR is case sensitive, so this is not the same as \fBf6\fR). Later you can use this variable for example in the expression .nf ==> 123**(F6 - 1) mod F6. -: 688_66214_58712_63971 .fi which shows (by Fermat's theorem) that F6 is not a prime number. .br The three most recent results are stored in the pseudo variables \fB_\fR, \fB__\fR, and \fB___\fR. For example you can store the last result in the variable x by the command .nf ==> x := _. -: 688_66214_58712_63971 .fi As you can see in the above examples, \fBaribas\fR uses the underscore \fB_\fR to structure the output of big integers (>= 2**32). Also for input of integers you may use the underscore, the only condition is that immediately before and after the underscore there are digits, example: .nf ==> z := 123_4567_890. -: 1234567890 .fi Here the output contains no underscore, which shows that z is less than 2**32. .P \fBAribas\fR has several built-in functions for factorization, for example \fIrho_factorize\fR, which uses Pollard's rho algorithm. .nf ==> rho_factorize(F6). working .. factor found after 512 iterations -: 274177 .fi To find the remaining cofactor, give the command .nf ==> x := F6 div _. -: 6728_04213_10721 .fi To test whether this factor is prime, Rabin's probabilistic test \fIrab_primetest\fR can be applied: .nf ==> rab_primetest(x). -: true .fi The function \fIrho_factorize\fR is good for finding small factors (say up to 10 decimal digits); for more complicated factorization tasks a more powerful algorithm like the quadratic sieve \fIqs_factorize\fR should be used .nf ==> qs_factorize(2**128+1). .fi (Depending on the power of your computer, it will take a few seconds up to a few minutes to get a prime factor of the 7th Fermat number.) .\"--------------------------------------------------------- .SS Control structures The \fIfor\fR loop and the \fIwhile\fR loop in \fBaribas\fR have a syntax as in Modula-2. For example, the following command sequence calculates the factorial of 100. .nf ==> x := 1; for i := 2 to 100 do x := x*i; end; x. .fi As you can see in this example, the input may extend over several lines. .P The above \fIfor\fR loop is equivalent to the following \fIwhile\fR loop .nf ==> x := 1; i := 2; while i <= 100 do x := x*i; inc(i); end; x. .fi .P The branching construct .br .B if .I ... .B then .I ... .B elsif .I ... .B else .I ... .B end .br has also the same syntax as in Modula-2. .\"--------------------------------------------------------- .SS Multiprecision floating point arithmetic \fBAribas\fR supports different types of floating point numbers which are internally represented with mantissas of different bit-length: .nf single_float 32 bits double_float 64 bits long_float 128 bits .fi and several higher precisions up to an implementation dependent limit, typically 1024 or 4096 bits, which can be determined by the function \fImax_floatprec()\fR. By default, when calculating with numbers of data type \fIreal\fR, single_floats are used. This corresponds to a precision of 9 to 10 decimal places. A precision of 4096 bits corresponds to over 1200 decimal places. The precision can be changed using the function \fIset_floatprec\fR. The function takes one integer argument, which is the desired precision in bits. It is automatically rounded to the next higher available value. For example, after .nf ==> set_floatprec(100). -: 128 .fi the floating point precision is 128 bits and you can calculate .nf ==> arctan(sqrt(3)). -: 1.04719_75511_96597_74615_42144_61093_16762_8 ==> _/pi. -: 0.33333_33333_33333_33333_33333_33333_33333_33 .fi .\"--------------------------------------------------------- .SS User defined functions The user can define his or her own functions. A typical example looks like .nf ==> function fac(n: integer): integer; var x,i: integer; begin x := 1; for i := 2 to n do x := x*i; end; return x; end. .fi If you have entered this correctly, \fBaribas\fR echoes the function name .nf -: fac .fi and from now on you can use \fIfac\fR in the same way as a built-in function, e.g. .nf ==> fac(32). -: 2_63130_83693_36935_30167_21801_21600_00000 .fi Note that inside function definitions all used variables must be explicitly declared, whereas on top level of the \fBaribas\fR interpreter variables can be simply created by assignments. Here is another example, which shows some other data types supported by \fBaribas\fR: .nf ==> function sqrt_list(n: integer): array of real; var vec: array[n] of real; i: integer; begin for i := 1 to n do vec[i-1] := sqrt(i); end; return vec; end. .fi This function returns an array of the square roots of the integers from 1 to n, for example .nf ==> sqrt_list(10). -: (1.00000000, 1.41421356, 1.73205081, 2.00000000, 2.23606798, 2.44948974, 2.64575131, 2.82842712, 3.00000000, 3.16227766) .fi In a bigger programming project where you need several functions you would not enter them directly at the \fBaribas\fR prompt but prepare the function definitions with an external text editor and save them in a file with the extension \fB.ari\fR , for example \fBabcd.ari\fR . This file can then be loaded by \fBaribas\fR using the command .nf ==> load("abcd"). .fi If there is a syntax error in the file, you get an error message of the form .nf error in line <= 23 of loaded file if: end expected .fi which tells you (in this example) that there is an error in the \fBif\fR construct in line 23 or earlier in the file. (Note that the error messages are sometimes not very precise.) You can then correct the error and load the file again. .\"-------------------------------------------------------- .SS Online help The command .nf ==> symbols(aribas). .fi returns a list of all keywords and names of builtin functions of \fBaribas\fR. This list has about 180 entries, and begins and ends as follows: .P (ARGV, _, __, ___, abs, alloc, and, arccos, arcsin, arctan, arctan2, aribas, array, atof, atoi, begin, binary, bit_and, bit_clear, bit_length, ...... , tolower, toupper, transcript, true, trunc, type, user, var, version, while, write, write_block, write_byte, writeln) .P For most of the symbols in this list, you can get a short online help using the function \fIhelp()\fR. For example, the command .nf ==> help(ARGV). .fi gives an information on the builtin variable \fIARGV\fR, whereas .nf ==> help(while). .fi describes the syntax of the \fIwhile\fR loop. If you need more information than that contained in the online help, consult the documentation which can be found in \fI/usr/share/doc/aribas\fR. .\"-------------------------------------------------------- .SS How to exit To end an \fBaribas\fR session, type \fIexit\fR at the \fBaribas\fR prompt .nf ==> exit .fi and then press the RETURN (ENTER) key. .P If you don't want to leave \fBaribas\fR, but want to break out of an infinite loop or a calculation that lasts too long, type CONTROL-C (if you are running \fBaribas\fR from within Emacs, you must press CONTROL-C twice). This will (in most cases) stop the current calculation and return to the \fBaribas\fR prompt. .P When you are not using the Emacs interface but the command line version of \fBaribas\fR, you sometimes get into the following situation: Some previous line contains a typing error, but you cannot return to that line to correct it. In this case you should simply type a full stop `\fB.\fR' , followed by RETURN. You will get an error message which you can safely ignore, and a new prompt \fB==>\fR appears, allowing you to try again. .\"-------------------------------------------------------- .SH COMMAND LINE ARGUMENTS .PP .B aribas [\fIoptions\fR] [<\fIari-file\fR> [<\fIarg1\fR> <\fIarg2\fR> ...]] .SS options The following options are available: .TP .B -q (quiet mode) Suppresses all messages to the screen (version no, copyright notice, etc.) when \fBaribas\fR is started .TP .B -v (verbose mode, default) Does not suppress messages to the screen when \fBaribas\fR is started. .TP .B -c \fBaribas\fR does its own line breaking when writing to the screen. Normally it supposes that the screen (or the window in which \fBaribas\fR runs) has 80 columns. With the -c option you can set another number, which must be between 40 and 160 (in decimal representation). For example, if you run \fBaribas\fR in an Xterm window with 72 columns, use the option -c72 (or -c 72, the space between -c and the number is optional). .TP .B -m Here is a number (in decimal representation) between 64 and 16000. This number indicates how many Kilobytes of RAM \fBaribas\fR should use for the \fBaribas\fR heap. The default value depends on the options used when \fBaribas\fR was compiled. Typically, under UNIX or LINUX it is 6 Megabytes, corresponding to -m6000 .TP .B -h The online help of \fBaribas\fR depends on a file aribas.hlp which should be situated in the range of the environment variable PATH. If this is not the case you can specify the exact path of the help file with the -h option. If for example the file aribas.hlp is in the directory /usr/local/lib, use the option -h /usr/local/lib (the space after -h is not necessary). The -h option can also be used if the help file has a different name. If the help file is named help-aribas and lies in the directory /home/joe/ari, use -h/home/joe/ari/help-aribas. With a properly installed Debian package of \fBaribas\fR it should not be necessary to use this option. .TP .B -p With this option you can specify a search path for loading files with \fBaribas\fR source code. may be either the (absolute) pathname of one directory or several pathnames separated by colons. Suppose that you have called \fBaribas\fR with the option -p/usr/local/lib/aribas:~/ari/examples and that your home directory is /home/alice/. Then the command ==> load("factor"). will search the file factor.ari first in the current directory, then in the directory /usr/local/lib/aribas and finally in /home/alice/ari/examples. .TP .B -b Batch mode when loading an \fBaribas\fR source code file from the command line, see below. .P One letter options which require no arguments may be merged, for example aribas -q -b is equivalent to aribas -qb .\"--------------------------------------------------------- .SS Further command line arguments .TP .B The next command line argument after the options is interpreted as the name of a file with \fBaribas\fR source code. If the file name has the extension .ari, this extension may be omitted. The file is loaded as if the command \fIload("")\fR had been given after the start of \fBaribas\fR at the \fBaribas\fR prompt. If the file is not found in the current directory it is searched in the directories specified by the -p option. If the option -b was given, the file is loaded and executed. Afterwards \fBaribas\fR exits without showing it's prompt. If the file cannot be loaded completely because of an error, \fBaribas\fR exits immediately after the error message. .TP .B ... When further command line arguments follow \fI\fR, they are collected (as strings) together with \fI\fR in the vector \fIARGV\fR which can be accessed from within \fBaribas\fR. Example: If you call \fBaribas\fR with the command line aribas startup 4536 eisenstein and the current directory contains the file startup.ari, then \fBaribas\fR loads it and the vector \fIARGV\fR has the form .nf ==> ARGV. -: ("startup", "4536", "eisenstein") .fi If you need some arguments as numbers and not as strings, you can transform them by \fIatoi\fR (or \fIatof\fR); in our example .nf ==> x := atoi(ARGV[1]). -: 4536 .fi will do it. The length of the vector \fIARGV\fR can be determined by \fIlength(ARGV)\fR. .\"------------------------------------------------------------- .SH RUNNING ARIBAS WITHIN EMACS You can run \fBaribas\fR from within Emacs by giving the command (in Emacs' minibuffer) .nf M-x run-aribas .fi (If you don't have a META key, use ESC x instead of M-x) Then \fBaribas\fR will be loaded into an Emacs window with name *aribas* and you can edit your input to \fBaribas\fR with the usual Emacs commands. .P If your input ends with a full stop '.' and you press RETURN, it is sent to \fBaribas\fR. If however your complete input does not end with a full stop, (for example in response to a \fIreadln\fR), the input is sent to \fBaribas\fR by C-j (Control-j) or C-c RETURN. .P If you want to repeat a previous input, M-p (or ESC p) cycles backward through input history, and M-n (or ESC n) cycles forward. .P A Control-C is sent to \fBaribas\fR by C-c C-c (press C-c twice). .P It is also possible to start \fBaribas\fR from Emacs with command line arguments. For this purpose the command .nf C-u M-x run-aribas .fi has to be given. Then a prompt .nf run-aribas: aribas .fi appears in the Minibuffer of Emacs and you can complete the command line, for example .nf run-aribas: aribas startup 4536 eisenstein .fi (see above). .\"------------------------------------------------------------- .SH CONFIGURATION FILE Options for running \fBaribas\fR can be specified also using a configuration file with name \fB.arirc\fR. \fBAribas\fR searches for a configuration file in the following order: 1) the current directory 2) the home directory of the user There is a third possibility: You can define an environment variable \fBARIRC\fR containing the name of the configuration file (which may be different from .arirc), including the full path. In the configuration file you can specify all command line options described above which begin with a - sign, however a separate line must be used for every single option. Lines beginning with the character # or empty lines are ignored. In addition to the options described above, the configuration file may contain \fBaribas\fR source code. For this purpose there must be a line reading .B -init Then everything after this line is treated as \fBaribas\fR source code and executed when \fBaribas\fR is started. The existence of a configuration file for \fBaribas\fR does not exclude the possibility to give command line arguments. If an option (e.g. the -m option) is specified both in the configuration file and the command line but with different values, then the specification at the command line is valid. Analogously, a -v option on the command line overrides a -q option in the configuration file. If there is -init code in the configuration file and an argument at the command line, then the -init code is executed first and afterwards the is loaded and its code executed. .SH FILES .TP .B $ARIRC, .arirc, $HOME/.arirc Optional configuration file. .SH ENVIRONMENT VARIABLES .TP .B $ARIRC Location of the optional configuration file. .SH SEE ALSO .BR emacs (1) .P More information on how to use \fBaribas\fR can be found in \fI/usr/share/doc/aribas\fR. .P The \fBaribas\fR home page is \fIhttp://www.mathematik.uni-muenchen.de/~forster/sw/aribas.html\fR. .\"------------------------------------------------------------- .SH BUGS Bug reports should be sent by email to forster@mathematik.uni-muenchen.de .SH AUTHOR Otto Forster is the author of the aribas program. This man page was compiled by Ralf Treinen from the aribas documentation for the Debian package of aribas, and supplemented by the author. aribas165b/doc/aribas.hlp0000644000076600000240000024165614660570652014332 0ustar ottostaffARIBAS Interpreter for Arithmetic, version 1.60, Aug. 2007 written by 0. Forster, email forster@mathematik.uni-muenchen.de File aribas.hlp for online help for the command line version of ARIBAS. This is not a Windows Help File, but a pure ASCII text file. Under MS-DOS, this file should lie in the same directory as aribas.exe; under UNIX or LINUX, it must be in a directory which is in the search path #---------------------------------------------------------------- Date of last change of this help file: 2007-08-20 #---------------------------------------------------------------- ?if ?then ?else ?elsif if then elsif then else end; There may be more (or zero) elsif parts. The else part may also be absent. Please note the spelling elsif. SEE ALSO: while #---------------------------------------------------------------- ?while ?do while do end; If evaluates to true, the statement sequence is executed (this can change the value of ). If is still true, is again executed. This is repeated until becomes false or the while loop is left by a return or a break statement. SEE ALSO: for, break, continue, return #---------------------------------------------------------------- ?for ?to ?by for-loop: for := to do end; for := to by do end; must be an integer variable, , and must be integer expressions. Example: ==> for k := 9 to 0 by -2 do write(k:3); end. 9 7 5 3 1 SEE ALSO: while, break, continue #---------------------------------------------------------------- ?break break The command break causes (as in C) the immediate leaving of a for or a while loop. Example: ==> for x := 10**7+1 to 10**8 by 2 do if factor16(x) = 0 then break; end; end; x. -: 10000019 SEE ALSO: while, for, continue, factor16 #---------------------------------------------------------------- ?continue continue The continue statement works as in C. If within a while or a for loop the continue statement is encountered, the rest of the current round of the loop is skipped and execution continues with the next round of the loop. Example: ==> for i := 1 to 10 do write(" #"); if i = 7 then continue end; write(i); end. produces the following output: #1 #2 #3 #4 #5 #6 # #8 #9 #10 SEE ALSO: break #---------------------------------------------------------------- ?div ?mod x div y x mod y div and mod are binary, left associative infix operators which may be applied only to integers and give an integer result. x div y returns the greatest integer less than or equal to x/y. The operator mod is defined by the equation x = (x div y) * y + (x mod y) The divisor y must be non-zero. SEE ALSO: divide #---------------------------------------------------------------- ?divide divide(x,y: integer): array[2]; Returns a pair (q,r) of integers such that q = x div y and r = x mod y. The argument \cc{y} must be non-zero. Example: ==> divide(100,7). -: (14, 2) ==> divide(-100,7). -: (-15, 5) SEE ALSO: div #---------------------------------------------------------------- ?boolean ?true ?false boolean The data type boolean comprises the truth values false and true. The logical operators not, and, or apply to boolean operands in the usual way and yield boolean results. Boolean values are also the result of arithmetic relational operators. In every place where ARIBAS expects a boolean value (e.g. as conditions in the if or while constructions), one can also use integer values. Then the value 0 is considered as false and every nonzero integer counts as true (this is the same behaviour as in the programming language C). SEE ALSO: and, or, not, if #---------------------------------------------------------------- ?not ?and ?or not, and, or not is a unary prefix operator, whereas and, or are binary infix operators. They may be applied to boolean arguments. The evaluation of the arguments of the binary operators and, or proceeds from left to right and is stopped as soon as the result is determined. Thus an expression like u > 0 and v/u < 1 is admissible, which would generate an error for u=0 if always both arguments of the and-operator were evaluated. SEE ALSO: boolean #----------------------------------------------------------------------- ?set_printbase set_printbase(b: integer): integer; The integer b must be one of the numbers 2, 8, 10, 16. The effect of this function is that subsequent output of integers is done in base b representation. Return value is the newly set print base. (If b is not admissible, the old print base is not altered.) Example: ==> set_printbase(8). -: 0o10 ==> 255. -: 0o377 For integers written in bases other than 10, the following prefixes are used: 0x for base 16, 0o for base 8 and 0y for base 2. SEE ALSO: get_printbase #---------------------------------------------------------------- ?get_printbase get_printbase(): integer; Returns the print base which is currently used. SEE ALSO: set_printbase #---------------------------------------------------------------- ?max_intsize max_intsize(): integer; Returns the maximum number of decimal places of integers supported by ARIBAS. This number depends on the options when ARIBAS was compiled and is typically between 20000 and 64000. SEE ALSO: integer #---------------------------------------------------------------- ?sum ?product sum(vec: array of integer): integer; sum(vec: array of real): real; product(vec: array of integer): integer; product(vec: array of real): real; Returns the sum resp. the product of all components of vec. SEE ALSO: max, min #---------------------------------------------------------------- ?even ?odd even(x: integer): boolean; odd(x: integer): boolean; Tests if x is even resp. odd. #---------------------------------------------------------------- ?max ?min max(x1,...,xn: integer): integer; max(x1,...,xn: real): real; min(x1,...,xn: integer): integer; min(x1,...,xn: real): real; Returns the maximum (resp. minimum) of the arguments x1,...,xn. max(vec: array of integer): integer; max(vec: array of real): real; min(vec: array of integer): integer; min(vec: array of real): real; Returns the maximum (resp. minimum) of all components of vec. #---------------------------------------------------------- ?abs abs(x: integer): integer; abs(x: real): real; Returns the absolute value of x. #---------------------------------------------------------- ?inc inc(var x: integer [; delta: integer]): integer; Increases the integer variable x by delta (by default delta = 1) und returns the increased value of x. Functionally equivalent to x := x + delta. The variable parameter x may also be an array element. Be aware of side effects; constructions like inc(vec[inc(k)]) may lead to an unexpected result! SEE ALSO: dec #---------------------------------------------------------- ?dec dec(var x: integer [; delta: integer]): integer; Decreases the integer variable x by delta (by default delta = 1) und returns the decreased value of x. Functionally equivalent to x := x - delta. The variable parameter x may also be an array element. Be aware of side effects; constructions like dec(vec[dec(k)]) may lead to an unexpected result! SEE ALSO: inc #---------------------------------------------------------- ?gcd gcd(x1,...,xn: integer): integer; Returns the greatest common divisor of the integers x1,x2,...,xn. For n = 1, one has gcd(x) = abs(x); if n = 0, then gcd() = 0. gcd(vec: array of integer): integer; Returns the greatest common divisor of all components of vec. SEE ALSO: gcdx #---------------------------------------------------------- ?gcdx gcdx(x,y: integer; var u,v: integer): integer; Returns the greatest common divisor d of x, y. At the same time, the variables u and v are set to values such that d = u*x + v*y Example: ==> gcdx(7,12,u,v). -: 1 ==> (u,v). -: (7, -4) SEE ALSO: gcd, mod_inverse #---------------------------------------------------------- ?mod_inverse mod_inverse(x, mm: integer): integer; If x and mm are reatively prime, this function returns the inverse of x modulo mm. Otherwise the return value is 0. Examples: ==> mod_inverse(3,17). -: 6 ==> mod_inverse(3,18). -: 0 SEE ALSO: gcdx #-------------------------------------------------------------- ?isqrt isqrt(x: integer): integer; x must be a non-negative integer. Returns the greatest integer y such that y*y <= x. SEE ALSO: sqrt, gfp_sqrt #------------------------------------------------------------- ?gfp_sqrt gfp_sqrt(p,x: integer): integer; p must be an odd prime and x an integer which is a square modulo p, i.e. jacobi(x,p) /= -1. The function returns a square root of x modulo p, that is, a square root in the field GF(p). Example: ==> p := next_prime(10**6). -: 1000003 ==> x := 10. -: 10 ==> jacobi(x,p). -: 1 ==> y := gfp_sqrt(p,x). -: 394215 ==> y**2 mod p. -: 10 SEE ALSO: isqrt #------------------------------------------------------------- ?factorial factorial(n: integer): integer; n must be a non-negative integer. Returns the factorial of n, (usually denoted by n!). Example: ==> factorial(8). -: 40320 #------------------------------------------------------------- ?mod_coshmult mod_coshmult(x,s,mm: integer): integer; If x is an integer and xi a number such that cosh(xi) = x, then cosh(s*xi) is an integer for all natural numbers s. The function returns this number modulo mm. The result can be obtained by the following recursively defined (Lucas) sequence: a(0) := 1; a(1) := x; a(k+2) := 2*x*a(k+1) - a(k); The result is the number a(s) mod mm. This function is useful to implement the (p+1)-factorization method. SEE ALSO: mod_pemult #------------------------------------------------------------- ?mod_pemult mod_pemult(x,s,a,mm: integer): array[2] of integer; Let pe be the Weierstrass pe-function on the elliptic curve E(a) y*y = x*x*x + a*x*x + x and let xi be a point on the curve with pe(xi) = x. Then s*xi is a point of E(a) (with respect to the abelian group structure on the elliptic curve). If s*xi is not a pole of pe, then pe(s*xi) = u/v is a rational number. (We may suppose that u and v are relatively prime.) If v is relatively prime to mm, the function mod_pemult(x,s,a,mm) returns (z,1), where z is an integer satisfying z*v = u mod mm (i.e. we have z = u/v in Z/mmZ). If v and mm have a greatest common divisor d > 1, the function returns (d,0). If s*xi is a pole of pe, the return value is (mm,0). This function is useful for the factorization with elliptic curves. SEE ALSO: mod_coshmult #--------------------------------------------------------------- ?factor16 factor16(x [,x0 [,x1]]: integer): integer; factor16(x) seeks a prime divisor p of x with p < min(2**16,x). If such a prime divisor exists, the smallest one is returned. Otherwise the function returns 0. If the optional arguments x0 resp. x0 and x1 are supplied, only prime divisors p satisfying the additional conditions p >= x0 resp. x0 <= p <= x1 are considered. Examples: ==> factor16(2**32 + 1). -: 641 ==> factor16(2**32 + 1, 642). -: 0 SEE ALSO: prime32test, rho_factorize #------------------------------------------------------------- ?prime32test prime32test(x: integer): integer; Tests if abs(x) is a prime number < 2**32. If this is true, the function returns 1. If abs(x) < 2**32, but is not prime, 0 is returned. For abs(x) >= 2**32, the function returns -1. SEE ALSO: rab_primetest, factor16 #------------------------------------------------------------ ?rab_primetest rab_primetest(x: integer): boolean; Performs the Rabin probabilistic prime test. If the function returns false, the number is certainly composite. A 'random ' number x, for which factor16(x) = 0 and rab_primetest(x) = true is prime with high probability. An exception are numbers constructed purposely to fool the Rabin prime test. But also for these numbers the error probability is less than 1/4. To decrease the error probability, one can repeat the test several times. SEE ALSO: prime32test, factor16 #---------------------------------------------------------- ?jacobi jacobi(a,m: integer): integer; Returns the Jacobi symbol of a over m. The module m must be an odd integer; a may be an arbitrary integer, the result depends only on the residue class of a modulo m. If a and m are not relatively prime, the return value is 0, otherwise it is 1 or -1. If p is an odd prime and a not a multiple of p, then jacobi(a,p) = 1 if and only if a is a quadratic residue modulo p. #------------------------------------------------------------ ?rho_factorize rho_factorize(x:integer [; b: integer]): integer; Tries to factorize x using Pollard's rho-algorithm. The optional argument b is a bound for the maximal number of steps (default value b = 2**16). If the algorithm finds a factor, it is returned, in case of failure the return value is 0. The number x should be free of small prime factors (e.g. < 1000). Then, if x has a prime factor p < sqrt(x), the algorithm will in general find a factorization of x if b is a small multiple of sqrt(p). If the return value y is > 1 and < x, it is certainly a factor of x, but not necessarily prime. rho_factorize(x,0). rho_factorize(x,b,0). Silent version. With last argument 0, all messages to the screen are suppressed. SEE ALSO: cf_factorize, qs_factorize, factor16 #---------------------------------------------------------------- ?cf_factorize cf_factorize(x: integer [; mm: integer]): integer; Tries to factorize x using the Morrison-Brillhart continued fraction factorization algorithm. The run time does not depend on the size of the prime factors of x. (Hence, if it is known that x has small prime factors, another factorization method like rho_factorize should be used.) If the period of the continued fraction of sqrt(x) is too short, the factorization will fail. In this case one should supply a second argument, which must be an integer mm with 1 <= mm < 1024. Then the continued fraction expansion of sqrt(mm*x) will be used. cf_factorize(x,0). cf_factorize(x,mm,0). Silent version. With last argument 0, all messages to the screen are suppressed. SEE ALSO: rho_factorize, qs_factorize #---------------------------------------------------------------- ?qs_factorize qs_factorize(x: integer): integer; Tries to factorize x using the multiple polynomial quadratic sieve factorization algorithm. The run time does not depend on the size of the prime factors of x. (Hence, if it is known that x has small prime factors, another factorization method like rho_factorize should be used.) qs_factorize(x,0). Silent version. With second argument 0, all messages to the screen are suppressed. SEE ALSO: rho_factorize, cf_factorize, ec_factorize #------------------------------------------------------------------- ?ec_factorize ec_factorize(x: integer[; m: integer]): integer; Tries to factorize x by the elliptic curve method. The optional argument m is a bound for the number of elliptic curves used. If the algorithm finds a factor, it is returned, in case of failure the return value is 0. If the return value y is > 1, it is certainly a factor of x, but not necessarily prime. ec_factorize(x: integer; pbounds: array[2] [; m: integer]): integer; You may explicitely prescribe the prime bound and the bigprime bound by the second argument in form of a 2-dimensional vector pbounds = (bound1,bound2). The constant bound1 must be < 2**16 and bound2 < 2**24. The third optional argument m is the maximal number of elliptic curves used. SEE ALSO: qs_factorize #------------------------------------------------------------------- ?next_prime next_prime(x: integer): integer; Returns the smallest prime p >= x. If x > 2**32, p is only a prime with high probability, since the probabilistic Rabin primality test is used. The number returned has no prime factor < 2**16 and has passed the strong pseudo prime test with ten random bases. next_prime(x,0). Silent version. With second argument 0, all messages to the screen are suppressed. SEE also: rab_primetest #------------------------------------------------------------------- ?bit_test bit_test(x,n: integer): integer; Returns 1, if the bit in position n of x is set, otherwise returns 0. Negative integers are thought to be in two's complement representation, where the sign bit extends to infinity at the left hand side. For example, the bit pattern of the two's complement representation of -1 is ......11111111111111111111111111111111 The count of positions begins with 0 (the bit i position n has weigth 2**n). For example, bit_test(x,0) = 1 if and only if x is odd. SEE ALSO: bit_set, bit_clear #---------------------------------------------------------------- ?bit_set bit_set(x,n: integer): integer; Sets the bit in position n of the integer x equal to 1 and returns the modified integer. Example: ==> bit_set(16,2). -: 20 SEE ALSO: bit_test, bit_clear #---------------------------------------------------------------- ?bit_clear bit_clear(x,n: integer): integer; Clears the bit in position n of the integer x (i.e. sets it equal to 0) and returns the modified integer. Examples: ==> bit_clear(20,2). -: 16 ==> bit_clear(-1,0). -: -2 SEE ALSO: bit_test, bit_set #---------------------------------------------------------------- ?bit_shift bit_shift(x,n: integer): integer; The number n may be positive, negative or zero. If n >= 0, bit_shift(x,n) is a shift of the bit representation of x of n positions to the left (i.e. in direction of more significant bits); this is equivalent to a multiplication by 2**n. If n < 0, this is a shift of abs(n) positions to the right (i.e. in direction of less significant bits); equivalent to x div 2**abs(n). Examples: ==> bit_shift(-7,3). -: -56 ==> bit_shift(-7,-1). -: -4 ==> bit_shift(-7,-100). -: -1 SEE ALSO: bit_test #---------------------------------------------------------------- ?bit_not bit_not(x: integer): integer; Inverts all bits of x. Equivalent to -x-1. SEE ALSO: bit_test, bit_and #---------------------------------------------------------------- ?bit_and ?bit_or ?bit_xor bit_and(x,y: integer): integer; bit_or(x,y: integer): integer; bit_xor(x,y: integer): integer; Bitwise and, or resp. exclusive or of x and y. For example, bit_and(x,3) is equivalent to x mod 4. SEE ALSO: bit_not, bit_test #---------------------------------------------------------------- ?bit_length bit_length(x: integer): integer; Returns the smallest natural number n such that abs(x) < 2**n SEE ALSO: bit_count, bit_test #---------------------------------------------------------------- ?bit_count bit_count(x: integer): integer; Returns the number of bits equal to 1 in the binary representation of abs(x). Examples: ==> bit_count(0). -: 0 ==> bit_count(255). -: 8 ==> x := 10001. -: 10001 ==> write(x:base(2)). 100111_00010001 -: 1 ==> bit_count(x). -: 6 ==> bit_count(-x). -: 6 SEE ALSO: bit_test, bit_length #---------------------------------------------------------------- ?pi constant pi ==> pi. -: 3.14159265 Internally, pi is stored with a precision equal to max_floatprec(). ==> set_floatprec(long_float). -: 128 ==> pi. -: 3.14159_26535_89793_23846_26433_83279_50288_4 SEE ALSO: arctan2, set_floatprec, max_floatprec #---------------------------------------------------------------- ?real real The data type real comprises a computer approximation of the real numbers. Real literals are given in decimal representation, beginning with an optional sign + or -, then a non-empty sequence of decimal digits, an obligatory decimal point, a second non-empty sequence of decimal digits and an optional scaling factor, consisting of the symbol E (or e), an optional sign and a non-empty sequence of decimal digits. Examples: 0.3 +3.1e-45 -0.00007E1000 The following forms are not admissible real literals: .333 333e-3. (The number which is meant by these symbols may be represented by 0.333 or 333.0e-3). SEE ALSO: set_floatprec, get_floatprec, decode_float, float #---------------------------------------------------------------- ?floor floor(x: real): integer; Returns the greatest integer n <= x. Examples: ==> floor(pi). -: 3 ==> floor(-pi). -: -4 SEE ALSO: trunc, round #---------------------------------------------------------------- ?trunc trunc(x: real): integer; If x >= 0, equivalent to floor(x). For x < 0, trunc(x) = -trunc(-x). Examples: ==> trunc(pi). -: 3 ==> trunc(-pi). -: -3 SEE ALSO: floor, round, frac #---------------------------------------------------------------- ?frac frac(x: real): real; Defined by the equation x = trunc(x) + frac(x) Examples: ==> frac(1.23). -: 0.230000000 ==> frac(-1.23). -: -0.230000000 SEE ALSO: trunc #---------------------------------------------------------------- ?round round(x: real): integer; Rounds x to the next integer n. If x has exactly the distance 1/2 from two integers, rounds to the even integer. Examples: ==> round(pi). -: 3 ==> round(3.5). -: 4 ==> round(2.5). -: 2 SEE ALSO: floor, trunc #---------------------------------------------------------------- ?set_floatprec ?single_float ?double_float ?long_float set_floatprec(bb: integer): integer; set_floatprec(Floattype): integer; This function serves to set the precision (in bits) which is used for subsequent calculations with reals. By default, a precision of 32 bits is used (corresponding to 9-10 decimal places), but it can be set to several higher values up to an implementation dependent limit, which can be determined by the function max_floatprec(). The argument of set_floatprec is either an integer bb, indicating the number of bits. If necessary, bb is rounded to the next higher available precision. The argument can also be a symbol Floattype, for which the following choice is available: single_float: 32 bits double_float: 64 bits long_float: 128 bits The function returns the new float precision. Example: ==> set_floatprec(long_float); x := sqrt(2). -: 1.41421356237309504880168872420969808 SEE ALSO: get_floatprec, max_floatprec #---------------------------------------------------------------- ?get_floatprec get_floatprec(): integer; get_floatprec(x: real): integer; In the first form (without arguments), the function returns the current float precision (in bits, i.e. one of the numbers 17, 32, 64, 128, 192). The default float precision of ARIBAS is 32 bits. If the argument is a real number x, the precision of x is returned. Examples: ==> set_floatprec(200). -: 256 ==> get_floatprec(pi). -: 4096 ==> get_floatprec(1/3). -: 256 SEE ALSO: set_floatprec, decode_float #---------------------------------------------------------------- ?max_floatprec max_floatprec(): integer; This function returns the maximum floating point precision (in bits) which is available in the current implementation of ARIBAS. Example: ==> max_floatprec(). -: 4096 SEE ALSO: set_floatprec, get_floatprec #---------------------------------------------------------------- ?decode_float decode_float(x: real): array[2] of integer; For a real number x, the function decode_float(x) returns a pair (mant, expo) of integers, reflecting the internal representation of x. The following equation holds: x = mant * 2**expo Example: ==> set_printbase(16). -: 0x10 ==> decode_float(-1/3). -: (-0xAAAA_AAAA, -0x21) SEE ALSO: get_floatprec, set_printbase, float #---------------------------------------------------------------- ?float float(x: integer [; Floattype]): real; float(x: real [; Floattype]): real; Floattype must be one of the symbols single_float, double_float, long_float or an integer bb indicating the float precision in bits. If this argument is not given, the current float precision is assumed. The function transforms the number x to data type real with float precision Floattype. Example: Suppose that the current float precision is single_float. ==> float(5). -: 5.00000000 SEE ALSO: set_floatprec, decode_float #---------------------------------------------------------------- ?sqrt ?exp ?log ?sin ?cos ?tan ?arctan ?arcsin ?arccos sqrt(x: real): real; exp(x: real): real; log(x: real): real; sin(x: real): real; cos(x: real): real; tan(x: real): real; arctan(x: real): real; arcsin(x: real): real; arccos(x: real): real; The functions sqrt (square root), exp, log (natural logarithm), sin, cos, tan, arctan, arcsin, arccos all expect one real argument and return a real. If the argument is an integer, it is automatically transformed to a real. Example: ==> log(2). -: 0.693147180 SEE ALSO: arctan2, set_floatprec, pi, isqrt #---------------------------------------------------------------- ?arctan2 arctan2(y,x: real): real; The two numbers x,y may not be simultaneously 0. The function returns an angle phi with -pi < phi <= pi, satisfying x = r * cos(phi); y = r * sin(phi); where r = sqrt(x*x + y*y). If x > 0, then arctan2(y,x) = arctan(y/x). ==> arctan2(0,-1). -: 3.14159265 SEE ALSO: arctan, pi #---------------------------------------------------------------- ?random random(x: integer): integer; random(x: real): real; Returns an integer (resp. real) pseudo random number z with 0 <= z < x. SEE ALSO: random_seed #---------------------------------------------------------- ?random_seed random_seed([s: integer]): integer; random_seed without an argument returns the present state of the random generator (which is an integer z with 2**48 <= z < 2**49). With an integer argument s, the state of the random generator is set to a value z such that z = s mod 2**48 and 2**48 <= z < 2**49. In this way one can generate reproducible values of the random function (for test purposes). SEE ALSO: random #---------------------------------------------------------- ?char char The data type char comprises 256 characters with code numbers 0 to 255. Characters with code numbers < 128 are the standard ASCII characters (they comprise printable characters and control characters); characters with code number >= 128 are system dependent. Character literals of printable characters are given by enclosing the symbol between single quotes, as in 'A'. The function chr transforms integer values from 0 to 255 into the corresponding characters. In this way, also the non-printable characters can be generated. For example, chr(7) is the bell character (which usually generates a beep when output to the terminal). SEE ALSO: chr, ord, string #---------------------------------------------------------- ?chr ?ord chr(n: integer): char; ord(ch: char): integer; The function chr generates the character with ASCII-Code n (0 <= n < 256), ord is the inverse function of chr. Examples: ==> chr(63). -: '?' ==> ord('?'). -: 63 SEE ALSO: char #----------------------------------------------------------*) ?concat concat(arg0, arg1, ... , argn): string; The function concat expects one or more arguments which must be strings or characters. The result is a string which is the concatenation of all arguments. Example: ==> concat("string",'_',"split"). -: "string_split" Using concat, one can construct strings with embedded double quotes: ==> concat("123",'"',"456"). -: "123"456" SEE ALSO: string_split #------------------------------------------------------------ ?toupper toupper(str: string): string; toupper(ch: character): character; Transforms a string resp. a character to upper case. Only characters between 'a' and 'z' are affected. All others remain untouched. Example: ==> toupper("Zapp-up!"). -: "ZAPP-UP!" SEE ALSO: tolower #------------------------------------------------------------- ?tolower tolower(str: string): string; tolower(ch: character): character; Transforms a string resp. a character to lower case. Only characters between 'A' and 'Z' are affected. All others remain untouched. Examples: ==> tolower("ABCdef123"). -: "abcdef123" ==> tolower('Z'). -: 'z' SEE ALSO: toupper #---------------------------------------------------------- ?string_split string_split(str: string [; sep: string]): array of string; Splits the string str into one or more parts and returns a vector whose components are these parts. The splitting considers as separators the characters contained in the string sep. If the argument sep is not supplied, SPACE, TAB, CR and NEWLINE are used by default. Examples; ==> string_split("abc def"). -: ("abc", "def") ==> string_split("abc def;xxx=yyy",";= "). -: ("abc", "def", "xxx", "yyy") SEE ALSO: concat #---------------------------------------------------------- ?substr_index substr_index(str, str1: string): integer; Searches for an occurrence of str1 as a substring of str and returns the position (the count begins with 0). If str1 does not occur as a substring of str, -1 is returned. Examples: ==> substr_index("string_split","split"). -: 7 ==> substr_index("string_split","Split"). -: -1 SEE ALSO: string_scan #---------------------------------------------------------- ?string_scan string_scan(str, set: string [; mode: boolean]): integer; When mode=true (default), searches for the first occurrence of a character from the string set in the string str and returns its position. If no character from set occurs in str, -1 is returned. Example: ==> str := "vec := (1,2,3)". -: "vec := (1,2,3)" ==> string_scan(str,"+-()"). -: 7 ==> string_scan(str,"+-[]"). -: -1 If mode=false, then the function searches for the first character in str, that does not belong to set. If all characters of str occur in set, then -1 is returned. For example, string_scan(str,"0123456789",false) = -1 is true if and only if the string str consists entirely of digits. SEE ALSO: substr_index #---------------------------------------------------------- ?itoa itoa(x: integer [; base: integer]): string; The integer x is converted to a string, giving the textual representation of this integer. The second optional argument is the base to be used, which may have one of the values 2,8,10,16. By default, base 10 is used. Example: ==> itoa(1234). -: "1234" ==> itoa(1234,16). -: "4D2" SEE ALSO: atoi, ftoa #------------------------------------------------------------ ?ftoa ftoa(x: real): string; The real number x is converted to a string. Examples: ==> ftoa(1/239). -: "0.00418410042" ==> ftoa(pi*10**100). -: "3.14159265E100" SEE ALSO: float_ecvt, itoa #---------------------------------------------------------- ?atoi atoi(s: string [; var len: integer]): integer; A string s, representing an integer, is transformed to this integer. The function may be called with an optional second variable argument len. The function stores in len an integer, which in general is the length of the string s. If len < length(s), then only the substring containing the first len characters of s is an admissible representation of an integer. In particular len=0 indicates a non-admissible string. Examples: ==> atoi("1234"). -: 1234 ==> atoi("0xFF 1234",len). -: 255 ==> len. -: 4 SEE ALSO: itoa, atof #---------------------------------------------------------- ?atof atof(s: string [; var len: integer]): real; A string s, representing a real number, is transformed to this real. The function may be called with an optional second variable argument len. The function stores in len an integer, which in general is the length of the string s. If len < length(s), then only the substring containing the first len characters of s is an admissible representation of a real. In particular len=0 indicates a non-admissible string. SEE ALSO: ftoa, atoi #---------------------------------------------------------- ?float_ecvt float_ecvt(x: real; ndig: integer; var decpos, sign: integer): string; The real x is transformed to a string of length ndig. The string contains only digits. The position of the decimal point is returned in the variable paramenter decpos (decpos < 0 means that the decimal point is to the left of the beginning of the string). The sign of x is returned in the variable parameter sign (sign = 0 means x >= 0, sign /= 0 means x < 0). float_ecvt is analogous to the UNIX C-function ecvt. Example: ==> float_ecvt(pi,10,decpos,sign). -: "3141592654" ==> decpos. -: 1 ==> sign. -: 0 SEE ALSO: ftoa #------------------------------------------------------------- ?md5 md5(str: string): byte_string; md5(str: byte_string): byte_string; Calculates the md5 fingerprint of the string (resp. byte_string) str. Example: ==> md5("1234567890"). -: $E807_F1FC_F82D_132F_9BB0_18CA_6738_A19F #------------------------------------------------------------- ?cardinal cardinal(b: byte_string): integer; Transforms a byte_string into a non-negative integer. The components of the byte_string are considered as the digits of an integer with respect to base 256. The leftmost byte corresponds to the least significant digit. Therefore the function returns the integer sum(b[i] * 256**i: 0 <= i < length(b)). Example: ==> cardinal($000A). -: 2560 SEE ALSO: integer, byte_string #---------------------------------------------------------- ?integer integer default data type of ARIBAS ARIBAS can handle integers of up to 20000 decimal digits. (*--------------------------------------------------------*) integer(b: byte_string): integer; Transforms a byte_string into an integer. The components of the byte_string are considered as the digits of an integer with respect to base 256 in two's complement representation. If len := length(b) and the most significant bit of b[len-1] is not set, then integer(b) = cardinal(b). But if the most significant bit of b[len-1] is set, then integer(b) = cardinal(b) - 256**len. SEE ALSO: cardinal, byte_string #----------------------------------------------------------------------- ?gf2nint gf2nint Data type of elements of the fields GF(2**n) of characteristic 2. To be able to do arithmetic in GF(2**n), the field must be initialized by the command gf2n_init(n). The elements of GF(2**n) are represented by polynomials of degree < n with coefficients 0 or 1, i.e. by bitvectors of length <= n. Literals of data type gf2nint are marked by the prefix 2x, followed by the hexadecimal representation of this bitvector. For example, in the field GF(2**8), the element 2x8A represents the class of the polynomial X**7 + X**3 + X, since 2**7 + 2**3 + 2 = 138 = 0x8A = 0y10001010. Also binary and octal representations are admissible; these are marked with the prefixes 2y and 2o respectively. For example, 2x8A = 2y10001010 = 2o212. Elements of data type gf2nint can be added, mulitiplied, divided and raised to integer powers: x + y, x*y, x/y, x**n. gf2nint(x: integer): gf2nint; Converts an integer to an element of data type gf2nint. Inverse function is integer(x: gf2nint): integer; SEE ALSO: gf2n_init, gf2n_fieldpol, gf2n_degree, gf2n_trace #---------------------------------------------------------- ?gf2n_init gf2n_init(deg: integer): integer; Initializes the field GF(2**deg), which is an extension of degree deg of the field with two elements GF(2). Return value is an integer f, representing an irreducible polynomial of degree deg. If the integer f in binary representation is f = sum(a_i * 2**i, i=0,1,...,deg), a_i = 0,1, then the corresponding polynomial f(X) in GF(2)[X] is f(X) = sum(a_i * X**i, i=0,1,...,deg). The field GF(2**deg) is constructed as GF(2)[X]/(f(X)). Example: ==> gf2n_init(53). -: 9_00719_92547_41063 ==> write(_:base(2)). 100000_00000000_00000000_00000000_00000000_00000000_01000111 -: 1 In this case the irreducible polynomial serving to construct the field GF(2**53) is f(X) = X**53 + X**6 + X**2 + X + 1. SEE ALSO: gf2nint, gf2n_fieldpol, gf2n_degree, max_gf2nsize, gf2n_trace #----------------------------------------------------------------------- ?gf2n_fieldpol gf2n_fieldpol(): integer; Returns the irreducible polynomial defining the field GF(2**n) which is active at present. The polynomial is represented by an integer; see description of the function gf2n_init(). SEE ALSO: gf2n_init, gf2n_degree, gf2nint #----------------------------------------------------------------------- ?gf2n_degree gf2n_degree(): integer; Returns the degree of the field GF(2**n) which is currently active. SEE ALSO: gf2n_init, gf2nint #----------------------------------------------------------------------- ?gf2n_trace gf2n_trace(z: gf2nint): integer; Returns the trace 0 or 1 of an element z in GF(2**n). The trace of z is 0 if and only if the quadratic equation x**2 + x = z has a solution x in GF(2**n). SEE ALSO: gf2n_init, gf2nint #----------------------------------------------------------------------- ?max_gf2nsize max_gf2nsize(): integer; Returns the maximal degree of a field GF(2**n) supported by the current version of ARIBAS. SEE ALSO: gf2n_init, gf2n_degree, gf2nint #----------------------------------------------------------------------- ?gf2X ARIBAS has several builtin functions dealing with polynomials over the field GF(2) with two elements 0,1. In these functions, polynomials are represented by integers. The correspondence is defined as follows: The integer f = sum( ai * 2**i, 0 <= i <= n), ai = 0,1 represents the polynomial F(X) = sum( ai * X**i, 0 <= i <= n). For example, ==> f := 2**7 + 2**6 + 1. -: 193 represents the polynomial F(X) = X**7 + X**6 + 1. SEE ALSO: gf2X_mult, gf2X_div, gf2X_gcd, gf2X_primetest #----------------------------------------------------------------------- ?gf2X_mult gf2X_mult(f,g: integer): integer; Multiplies two polynomials over GF(2) given by the integers f, g. Example: ==> f := 2**7 + 2**6 + 1. -: 193 ==> g := 2**6 + 2**4 + 1. -: 81 ==> h := gf2X_mult(f,g). -: 15505 ==> write(h:base(2)). 111100_10010001 -: 1 The product h represents the polynomial H(X) = X**13 + X**12 + X**11 + X**10 + X**7 + X**4 + 1. SEE ALSO: gf2X, gf2X_square, gf2X_divide #----------------------------------------------------------------------- ?gf2X_square gf2X_square(f: integer): integer; gf2X_square(f) is functionally equivalent to gf2X_mult(f,f), but runs faster. SEE ALSO: gf2X, gf2X_mult, gf2X_modpower #----------------------------------------------------------------------- ?gf2X_divide ?gf2X_div ?gf2X_mod gf2X_divide(f,g: integer): array[2]; gf2X_div(f,g: integer): integer; gf2X_mod(f,g: integer): integer; If f and g are two polynomials over GF(2) and g /= 0, then there exist polynomials q and r with deg(r) < deg(g) such that f = q*g + r The function gf2X_divide(f,g) returns the pair (q,r), the function gf2X_div(f,g) returns the quotient q and gf2X_mod(f,g) returns the remainder r. SEE ALSO: gf2X_mult, gf2X_gcd, gf2X_modpower #----------------------------------------------------------------------- ?gf2X_gcd gf2X_gcd(f,g: integer): integer; Returns the greatest common divisor of the polynomials f,g. Example: ==> f := 2**10 + 1. -: 1025 ==> g := 2**4 + 1. -: 17 ==> gf2X_gcd(f,g). -: 5 This shows that the gcd of the polynomials X**10 + 1 and X**4 + 1 is X**2 + 1. SEE ALSO: gf2X, gf2X_mod #----------------------------------------------------------------------- ?gf2X_modpower gf2X_modpower(g,n,F: integer): integer; Calculates the n-th power of the polynomial g modulo the polynomial F. Example: ==> g := 2**5 + 2**4 + 1. -: 49 ==> F := 2**10 + 1. -: 1025 ==> h := gf2X_modpower(g,12345,F). -: 67 ==> write(h:base(2)). 1000011 -: 1 Thus (X**5 + X**4 + 1)**12345 = (X**6 + X + 1) mod (X**10 + 1). SEE ALSO: gf2X, gf2X_mult, gf2X_square, gf2X_mod #----------------------------------------------------------------------- ?gf2X_primetest gf2X_primetest(f: integer): boolean; Tests whether the polynomial f is irreducible. Example: ==> f0 := 2**100 + 1. -: 1_26765_06002_28229_40149_67032_05377 ==> for k := 1 to 99 do f := f0 + 2**k; if gf2X_primetest(f) then writeln(k); break; end; end; f. 15 -: 1_26765_06002_28229_40149_67032_38145 This shows that the polynomial X**100 + X**15 + 1 is irreducible over GF(2). SEE ALSO: gf2X, gf2nint #----------------------------------------------------------------------- ?byte_string A byte_string is a finite sequence of bytes. Byte_string literals are written in the form $XXXXXX...XX, where XX stands for the hexadecimal representation of a byte. (*--------------------------------------------------------------------*) byte_string(x: integer [; len: integer]): byte_string; byte_string(x) transforms an integer x into a byte_string of length len (default = byte_length(x)). It is the inverse function of integer(bb: byte_string). If a second argument len is given and len < byte_length(x), then the byte_string is truncated and only the len least significant bytes are retained. If len > byte_length(x), bytes of value 0 (if x >= 0) resp. 0xFF (if x < 0) are added. Example: ==> byte_string(-1,4). -: 0xFFFF_FFFF (*--------------------------------------------------------------------*) byte_string(s: string): byte_string; Transforms an ordinary (text) string into a byte_string. The components of the resulting byte_string are the ASCII codes of the characters of s. SEE ALSO: integer, string #---------------------------------------------------------- ?string string The data type string comprises sequences of characters and serves to represent text. String literals are given by enclosing the character sequence between double quotes, as in "ABCD". Strings containing double quotes can be constructed using concat. One can access a single character of a string in the following way: ==> s := "abcdef"; s[3]. -: 'd' (*---------------------------------------------------------*) string(b: byte_string): string; Transforms a byte_string into a text string; inverse function of byte_string. Be careful if some components of the byte_string b are codes of non-printable control characters. SEE ALSO: byte_string, char, concat #------------------------------------------------------------- ?mem_btest mem_btest(var b: byte_string; n: integer): integer; Returns the value 1 or 0 of the bit at position n in the byte_string b (position is zero based). SEE ALSO: mem_bset, mem_bclear #---------------------------------------------------------- ?mem_bset mem_bset(var b: byte_string; n: integer): byte_string; Sets the bit at position n in the byte_string b to 1 and returns the modified byte_string. SEE ALSO: mem_bclear, mem_btest #---------------------------------------------------------- ?mem_bclear mem_bclear(var b: byte_string; n: integer): byte_string; Clears the bit at position n in the byte_string b (i.e. sets it to 0) and returns the modified byte_string. SEE ALSO: mem_bset, mem_btest, mem_not #---------------------------------------------------------- ?mem_not mem_not(var b: byte_string): byte_string; Inverts all bits in the byte_string b and returns the modified byte_string. SEE ALSO: mem_xor #---------------------------------------------------------- ?mem_or ?mem_and ?mem_xor mem_and(var b1,b2: byte_string): byte_string; mem_or(var b1,b2: byte_string): byte_string; mem_xor(var b1,b2: byte_string): byte_string; The first byte_string argument b1 is replaced by the bitwise and (resp. or, xor) of b1 and b2. The modified byte_string b1 is returned. SEE ALSO: mem_not, mem_shift, mem_btest #---------------------------------------------------------- ?mem_shift mem_shift(var b: byte_string; n: integer): byte_string; Performs a bit shift by abs(n) binary digits. If n > 0, the direction is from least-significant to most-significant, for n < 0, the shift is in the opposite direction. n bits are lost. They are replaced by 0's. Example: ==> bb := $ABCD; mem_shift(bb,4). -: $B0DA ==> mem_shift(bb,4). -: $00AB SEE ALSO: mem_not, mem_xor #---------------------------------------------------------- ?mem_bitswap mem_bitswap(var b: byte_string): byte_string; Within each byte of b, the 8 bits are swapped from most significant <--> least significant, that is, sum{b_k*2**k, 0 <= k < 8} is replaced by sum{b_k*2**(7-k), 0 <= k < 8}. The modified byte_string is returned. Example: ==> bb := $0102_1e2f. -: $0102_1E2F ==> mem_bitswap(bb). -: $8040_78F4 SEE ALSO: mem_byteswap, mem_btest #---------------------------------------------------------- ?mem_byteswap mem_byteswap(var b: byte_string; wordlen: integer): byte_string; The byte_string is subdivided in groups of wordlen bytes each. Within each group, the bytes are swapped from most significant <--> least significant. The modified byte_string is returned. Example: ==> bb := $AABBCCDDEE. -: $AABB_CCDD_EE ==> mem_byteswap(bb,2). -: $BBAA_DDCC_EE SEE ALSO: mem_bitswap, mem_shift #--------------------------------------------------------------- ?array ?of array of Type The array is a structured data type, consisting of finite sequences of components of a given (but arbitrary) data type Type. Array literals are given by a comma separated list of its components. The list is enclosed between a pair of parentheses ( and ), for example vec := (37, 41, -9). However, for arrays of length 1, braces must be used. vec1 := {37}. The expression (37) is interpreted by ARIBAS as the number 37. One may use braces instead of parentheses also for arrays of length > 1. The components of an array vec can be accessed as vec[i] where 0 <= i < length(vec). SEE ALSO: subarray, vector_ops, alloc, max_arraysize #--------------------------------------------------------------- ?subarray Besides accessing single components of an array, one can also access whole subarrays. If vec is an array, then vec[n1..n2] denotes the subarray consisting of all components vec[i] with n1 <= i <= n2. Example: ==> vec := (1,2,3,4,5,6,7,8,9,10). -: (1, 2, 3, 4, 5, 6, 7, 8, 9, 10) ==> vec[2..6]. -: (3, 4, 5, 6, 7) The upper bound may be omitted: vec[n1..] is equivalent to vec[n1..length(vec)-1]. Subarrays may also appear at the left hand side of assignments and thus allow the simultaneous modification of several components. SEE ALSO: array #--------------------------------------------------------------- ?vector_ops -vec, vec1 + vec2, vec1 - vec2 lambda * vec, vec * lambda, vec/lambda vec, vec1, vec2 may be of data type array of integer or array of real and lambda of data type integer or real. Calculate the negative of vec, sum and difference of vectors vec1 and vec2, resp. the product of the vector vec by the scalar lambda or 1/lambda. vec1 and vec2 need not have the same length; the shorter one is implicitely expanded to the greater length by appending zeroes. Examples: ==> -(1,1) + pi*(1,2,3). -: (2.14159265, 5.28318531, 9.42477796) ==> (100, 200, 300, 400)/1.95583. -: (51.1291881, 102.258376, 153.387564, 204.516752) vec div N, vec mod N Here vec must be an array of integers and N an integer /= 0. The operators div resp. mod are applied componentwise to the vector vec. Example: ==> (1000, 1100, 1200) mod 12. -: (4, 8, 0) SEE ALSO: sum, product, gcd, max, min #--------------------------------------------------------------- ?max_arraysize max_arraysize(): integer; In the present version of ARIBAS, lengths of arrays cannot be very large. The function max_arraysize returns the maximal admissible length. Typically, under UNIX, this value is about 64000, under MSDOS about 12000 or 16000. The maximal admissible length for strings and byte_strings is min(4*max_arraysize(), 2**16-1). SEE ALSO: array, alloc #--------------------------------------------------------------- ?sort sort(var vec: array of integer): array of integer; sort(var vec: array of real): array of real; sort(var vec: array of string): array of string; The array vec, which is passed to the function sort as a variable argument, is sorted in non-decreasing order (for strings, the lexicographic order with respect to the ASCII-codes of characters is used). The sorted array is returned. sort(var vec: array of Type; compfun: function): array of Type; The function sort may be given as a second optional argument a comparison function compfun(x,y: Type): integer; which must be a function of two arguments of the same data type as the components of the array. The relation defined by compfun(x,y) <= 0 must be transitive. Then vec is sorted in non-decreasing order, where x <= y is defined by compfun(x,y) <= 0. SEE ALSO: binsearch #--------------------------------------------------------------- ?binsearch binsearch(ele: ; var vec: array of [; compfun: function]): integer; The array vec must be a sorted array of elements of type . The function searches in this array for an occurrence of the element ele and returns its position (zero-based). If ele is not found, -1 is returned. The third argument of binsearch is a comparison function compfun(x,y: ): integer; which must be a function of two arguments of the same data type as the components of the array (see function sort). If vec is an array of integers, characters or strings, then the comparison function may be omitted. In this case the natural order (numerical resp. alphabetical) is assumed. SEE ALSO: sort #--------------------------------------------------------------- ?alloc alloc(Arraytype, Len [,Ele]): Arraytype; Arraytype must be one of the symbols array, string, byte_string. The function generates an array (resp. a string, a byte_string) of length Len, where all components are equal to Ele. If the argument Ele is not given, a default element is used. This default element is 0 for arrays, the space character ' ' for strings, and the zero byte for byte_strings. Examples: ==> alloc(array,10). -: (0, 0, 0, 0, 0, 0, 0, 0, 0, 0) ==> alloc(string,5,'A'). -: "AAAAA" ==> alloc(byte_string,5,127). -: $7F7F_7F7F_7F #---------------------------------------------------------- ?realloc realloc(var vec: ; len: integer [; ele]): The variable argument vec must be an array, a string or a byte_string. If the integer len is bigger than the length of vec, the function increases the length of vec to len by appending components of value ele at the end. If ele is not given, default values are used. The new array (resp. string}, byte_string) is returned and also placed in the variable vec. If len is equal to the length of vec, then vec remains unchanged. If len is smaller than the length of vec, then vec is truncated to this smaller length. Examples: ==> vec := (17,4,31). -: (17, 4, 31) ==> realloc(vec,5,53). -: (17, 4, 31, 53, 53) ==> bb := $AABB. -: $AABB ==> realloc(bb,10). -: $AABB_0000_0000_0000_0000 ==> s := "abcde". -: "abcde" ==> realloc(s,3). -: "abc" #---------------------------------------------------------- ?stack stack Builtin data type of ARIBAS. There are no stack literals. One can generate stacks by variable declarations. For example, the following top level declaration var st: stack; end. generates an empty stack. Afterwards, one can put elements onto the stack using stack_push. SEE ALSO: stack_push, stack_pop, stack_top, stack_reset, stack_empty stack2array #-------------------------------------------------------------------- ?stack_push stack_push(st: stack; ele: Type): Type; Puts an element ele (of arbitrary data type Type) on top of the stack st. The length of the stack is increased by 1. The return value of the function is ele. SEE ALSO: stack_arraypush, stack_pop, stack #----------------------------------------------------------------- ?stack_arraypush stack_arraypush(st: stack; vec: array of [; direction: integer]): integer; Pushes the components of the array vec onto the stack st. If the argument direction is positive or omitted, the order is from beginning to the end of vec. If direction is negative, the pushing occurs in reverse order. Return value is the number of elements pushed on st (= the length of vec). Examples: ==> var st: stack; end. -: var ==> vec := (1,2,3,4,5). -: (1, 2, 3, 4, 5) ==> stack_arraypush(st,vec,-1). -: 5 ==> vec1 := stack2array(st). -: (5, 4, 3, 2, 1) SEE ALSO: stack_push #----------------------------------------------------------------- ?stack_pop stack_pop(st: stack): Type; The stack st must be non-empty. The function removes the top element of st and returns it. The length of the stack is decreased by 1. SEE ALSO: stack_top, stack_push, stack #----------------------------------------------------------------- ?stack_top stack_top(st: stack): Type; Returns the top element of the stack st; the stack itself is not altered. SEE ALSO: stack_pop, stack #----------------------------------------------------------------- ?stack_reset stack_reset(st: stack): integer; Removes all elements from the stack st. There remains an empty stack. The function returns 0. SEE ALSO: stack_empty, stack #----------------------------------------------------------------- ?stack_empty stack_empty(st: stack): boolean; Tests if the stack st is empty. SEE ALSO: stack_reset, stack #----------------------------------------------------------------- ?stack2array stack2array(st: stack): array of Type; Returns an array of length equal to length(st) whose components are the elements lying on the stack. The element at the bottom of the stack becomes the component of index 0. After execution of this function, the stack st is empty. It is in the responsibility of the programmer to ensure that all elements have the correct data type. SEE ALSO: stack2string, stack_pop, stack #----------------------------------------------------------------- ?stack2string stack2string(st: stack): string; The elements on the stack st, which are strings or characters, are concatenated to a string. This string is returned. Elements of other data types on the stack are ignored. After execution of this function, the stack st is empty. Example: ==> var st: stack; end. -: var ==> stack_push(st,"stack"). -: "stack" ==> stack_push(st,pi). -: 3.14159265 ==> stack_push(st,'_'). -: '_' ==> stack_push(st,"push"). -: "push" ==> stack2string(st). -: "stack_push" SEE ALSO: stack2array, concat #----------------------------------------------------------------- ?transcript transcript([fnam: string]): boolean; Opens a log file with name fnam. The extension .log is appended automatically to fnam, if fnam has no extension. If no argument is given to transcript, "aribas.log" is used by default. For example, ==> transcript("a1"). -: true opens a file a1.log (if it exists already, its previous content is lost). The effect of transcript is that all subsequent interaction between the user and ARIBAS is transcribed to the log file until the log file is closed again with the command ==> transcript(0). The end of an ARIBAS session closes the log file automatically. #----------------------------------------------------------------- ?help help(Topic) Gives a short online help on Topic. For Topic one can use most symbols of the list returned by the command symbols(aribas). For example, ==> help(factor16). gives a short description of the builtin function factor16. Often, the help ends with a list of cross references (introduced by `SEE ALSO:'). Calling help for the topics listed there gives you further information. SEE ALSO: symbols #----------------------------------------------------------------- ?length length(x: array): integer; length(x: string): integer; length(x: byte_string): integer; Returns the length of the array (resp. string, byte_string) x length(st: stack): integer; Returns the length of the stack st, i.e. the number of elements (of arbitrary data type) which lie on the stack. length(f: file): integer; f must be a file opened for reading. Then the function returns the length of the file in bytes. SEE ALSO: byte_length, bit_length #-------------------------------------------------------------------- ?readln readln([f: file;] var arg1,...,argn): integer; Reads a line from file f, which must have been opened for reading. (If the file argument is not supplied, stdin is assumed, i.e. readln reads from the terminal.) The arguments arg1,...,argn must be of type integer, real, char or string. (A string variable consumes all characters until the end of line.) The return value of readln is the number of successfully read items. If the end of file is already reached before the call of readln, -1 is returned. For example, assume that x is an integer variable, c1, c2 are character variables and s is a string variable. If the current line in the file f is 1234 56 ab (where the line ends immediately after the character b), then readln(f,c1,x,c2,s) will return 4 and the variables will contain the following values: c1 = '1', x = 234, c2 = ' ', s = "56 ab". If the same line is read with readln(f,s,x,c1,c2), then the return value is 1, the variable s contains the string "1234 56 ab", and x, c1, c2 are undefined. readln(f) simply returns 0 and advances the file position to the beginning of the next line. SEE ALSO: open_read, writeln, read_byte, read_block #-------------------------------------------------------------------- ?write ?writeln write([f: file;] arg1,...,argn): integer; writeln([f: file;] arg1,...,argn): integer; Writes the arguments arg1,...,argn (which may have any data type) into a text file f, which must have been opened for writing. The function writeln adds a linefeed to the output. (If the file argument is not supplied, stdout is assumed, i.e. the functions write to the terminal.) Return value is the number of written arguments or -1 in case of error. SEE ALSO: open_write, open_append, flush #-------------------------------------------------------------------- ?flush flush([f: file]); If f is an output file (default f = stdout) to which write operations have been performed, but some of the data are still being held in a buffer, then flush writes all data actually to the file. SEE ALSO: write, write_byte #-------------------------------------------------------------------- ?stdout ?stdin ?stderr stdout stdin stderr Predefined file variables of ARIBAS, usually (if not redirected) connected to the terminal. The functions write and writeln, if not given a file argument, use stdout by default; the function readln, if not given a file argument, reads from stdin. Error messages of ARIBAS go to stderr. SEE ALSO: write, writeln, readln, flush #-------------------------------------------------------------------- ?file file Data type in ARIBAS. To access an external file, which is stored under a certain name somewhere on the hard disk or a floppy disk for read or write operations in ARIBAS, it must first be opened and assigned to a file variable. This is done with the functions open_read, open_append or open_write. SEE ALSO: open_read, open_append, open_write, readln, writeln, binary, read_byte, write_byte #-------------------------------------------------------------------- ?binary BINARY FILES In ARIBAS, files are text files by default. However, files can also be opened in binary mode for reading and writing using the functions open_write, open_read, open_append. In this case, a third argument, consisting of the keyword binary, must be given. Example: ==> open_read(f,"BIN.DAT",binary). This opens a file with name "BIN.DAT", which is supposed to exist, for reading in binary mode. For binary files there are the read operations read_byte and read_block and the write operations write_byte and write_block. The functions rewind and length may also be applied to binary files, which have been opened for reading. SEE ALSO: read_byte, read_block, write_byte, write_block, set_filepos open_read, open_write, open_append #-------------------------------------------------------------------- ?set_filepos set_filepos(f: file; pos: integer): integer; f must be a binary file, opened for reading and pos must be an integer satisfying 0 <= pos < length(f). Then set_filepos sets the position for the next read operation at pos bytes from the beginning of the file. If pos is not in the admissible range, no action is taken. Return value is the file position after execution of set_filepos. SEE ALSO: get_filepos, binary #-------------------------------------------------------------------- ?get_filepos get_filepos(f: file): integer; f must be a binary file, opened for reading. The function returns the current file position. SEE ALSO: set_filepos, binary #-------------------------------------------------------------------- ?read_byte read_byte(f: file): integer; Reads one byte at the current file position from a binary file opened for reading and increases the file position by 1. Return value is the read byte (an integer in the range 0 <= x < 256). If the file position is already end-of-file when read_byte is called, then -1 is returned and the file position remains unchanged. SEE ALSO: read_block, write_byte, binary #-------------------------------------------------------------------- ?read_block read_block(f: file; var block: byte_string; len: integer): integer; f must be a binary file opened for reading. The argument block must be a byte_string variable or a subarray of a byte_string with an actual length >= len. Then read_block reads len bytes from the file f (starting at the current file position) and stores them into the first len components of block. If the end-of-file is reached prematurely, the reading operation is stopped and only the bytes read so far are stored in block. Return value of read_block is the number of actually read bytes. The file position is advanced by this value. SEE ALSO: read_byte, write_block, binary #-------------------------------------------------------------------- ?write_byte write_byte(f: file; x: integer): integer: Writes one byte (given by the integer x in the range 0 <= x < 256) into a binary file f opened for writing (using open_write or open_append). Instead of an integer x one can use also a character. Return value in case of success is the written byte. In case of error, -1 is returned. SEE ALSO: write_block, read_byte, binary #-------------------------------------------------------------------- ?write_block write_block(f: file; var block: byte_string; len: integer): integer; f must be a binary file opened for writing. The argument block must be a byte_string variable or a subarray of a byte_string with an actual length >= len. Then write_block writes the first len bytes from block into the file f. Return value of write_block is the number of successfully written bytes. If no error occurs, this number equals len. SEE ALSO: write_byte, read_block, binary #-------------------------------------------------------------------- ?open_write open_write(var f: file; fnam: string): boolean; Opens a file with name fnam for write operations and sets the file variable f. (This file variable is needed for the write operations.) If a file with name fnam does not exist, it is created. Return value: true if the file has been succesfully opened, and false, if an error occurs. In case of success, the variable f is filled with a file descriptor value that must be used for subsequent write operations to the file. CAUTION: If a file with name fnam exists already, its previous content is overwritten and will be lost. SEE ALSO: write, open_append, binary #-------------------------------------------------------------------- ?open_append open_append(var f: file; fnam: string): boolean; Opens a file with name fnam for write operations and sets the file variable f. (This file variable is needed for the write operations.) If a file with name fnam does not exist, it is created. If the file exists already, the previous content is preserved and the new write operations are at the end of the file. Return value: true if the file has been succesfully opened, and false, if an error occurs. In case of success, the variable f is filled with a file descriptor value that must be used for subsequent write operations to the file. SEE ALSO: write, open_write, binary #-------------------------------------------------------------------- ?open_read open_read(var f: file; fnam: string): boolean; Opens an existing file with name fnam for sequential reading. Return value: true if the file has been succesfully opened, and false, if an error occurs. In case of success, the variable f is filled with a file descriptor value that must be used for subsequent read operations from the file. SEE ALSO: readln, open_write, binary #-------------------------------------------------------------------- ?rewind rewind(var f: file): boolean; If f is a file which has been opened for reading and from which some data have already been read, rewind(f) resets the file position for the the next read operation to the beginning of the file. Return value: true if successful, else false. SEE ALSO: set_filepos #-------------------------------------------------------------------- ?close close(f: file): boolean; Closes a file f which has been opened before. SEE ALSO: open_write, open_append, open_read #-------------------------------------------------------------------- ?load load(fnam: string): boolean; fnam must be the name of a text file with ARIBAS source code, the extension .ari may be omitted. Then load reads this file and executes all commands and function definitions in the file as if they had been input directly at the ARIBAS prompt. Returns true, if the load operation was successful. In case of error, an error message is written, specifying a line number, where the error was detected (actually the error might be in some previous line). load(fnam,0). With a second argument 0 the function load works in quiet mode, the messages to terminal are suppressed. #-------------------------------------------------------------------- ?system system(command: string): integer; The string command is handed to the command interpreter (resp. shell) of the system for execution. Return value is an error code or 0. For example, under MS-DOS, ==> system("dir"). generates a listing of the current directory. Under UNIX, you can use ==> system("ls -l"). for the same purpose. #----------------------------------------------------------------- ?getenv getenv(name: string): string; Returns the value of the environment variable name or the empty string, if this variable is not defined. Example: Under UNIX, ==> getenv("HOME"). returns the name of the home directory of the current user. #----------------------------------------------------------------- ?set_workdir set_workdir(path: string): string; Sets the current working directory to the one given by path. This can be either an absolute or a relative path. Return value is the new path. If the path does not exist, or ARIBAS is unable to open it, then the old working directory remains unchanged and the empty string is returned. Example: ==> set_workdir("D:\aribas\work"). -: "D:\aribas\work" (This example supposes that the directory "D:\aribas\work" exists.) SEE ALSO: get_workdir #----------------------------------------------------------------- ?get_workdir get_workdir(): string; Retrieves the current working directory. SEE ALSO: set_workdir #----------------------------------------------------------------- ?exit exit The command exit stops ARIBAS and returns to the shell or command interpreter from where ARIBAS was called. SEE ALSO: halt #----------------------------------------------------------------- ?halt halt([retcode: integer]): integer; A call to halt causes an immediate stop of the current program and a return to top level (even if halt occurs in a deeply nested function call). The return value is the optional argument retcode, which must be a 16-bit integer (default value 0). The function halt is mainly used to recover from serious errors. Note: In contrast to exit, halt does not stop ARIBAS, but returns to the ARIBAS prompt. SEE ALSO: exit #----------------------------------------------------------------- ?memavail memavail(): integer; Writes some memory statistics to the screen and returns the free space (measured in KB) on the ARIBAS heap. Since ARIBAS possesses a garbage collector using the half space method, the ARIBAS heap is subdivided into two equal parts. One part is active, memory requirements are satisfied from this part. The size of the two parts and the space still available in the active part is reported. If the memory in the active part is exhausted, the garbage collector is called automatically. The total number of garbage collections since the beginning of the current ARIBAS session is also given. The names of user defined functions and variables are stored by ARIBAS in a symbol table. The space still available for this purpose is also reported. One can suppress all messages by calling memavail with the argument 0. Example: ==> memavail(0). -: 82 SEE ALSO: gc #----------------------------------------------------------------- ?gc gc(): integer; Forces a garbage collection and returns the new amount of free memory (in KB) on the ARIBAS heap. The function outputs the same messages as the function memavail. A quiet version is gc(0). This is useful for example, if one wants to call some procedure only if a certain minimal amount of memory is available, as in the following code if gc(0) < 64 then writeln("not enough memory for procedure foo"); else foo(...); ... end; SEE ALSO: memavail #----------------------------------------------------------------- ?timer timer(): integer; Returns the number of milliseconds elapsed since a certain starting point dependent on the current computer session. (The precision is system dependent.) This can be used for example to measure the time needed to execute a certain function. Example: ==> t := timer(); x := isqrt(2*10**2000); timer() - t. -: 88 In the above example, which was done with the LINUX version of ARIBAS on a computer with a 80486 processor, 33MHz, the square root of 2 was calculated with a precision of 1000 decimal places in 88 milliseconds. SEE ALSO: gmtime #-------------------------------------------------------------------- ?gmtime gmtime(): string; Returns Greenwich Mean Time as a string in the format "YYYY:MM:DD:hh:mm:ss" (year, month, day, hour, minutes, seconds). You can use the function string_split to retrieve the components of this string and use it to write your own custumized time function. Example: ==> gmtime(). -: "2003:06:09:08:26:20" ==> tt := string_split(_,":"). -: ("2003", "06", "09", "08", "26", "20") ==> t0 := alloc(array,6); for k := 0 to 5 do t0[k] := atoi(tt[k]); end; t0. -: (2003, 6, 9, 8, 26, 20) gmtime(0): integer; If gmtime is called with the argument 0, then it returns the number of seconds passed since Jan. 1, 2000, 0:00 h GMT. SEE ALSO: timer #-------------------------------------------------------------------- ?aribas ?user ?symbols symbols(aribas). Returns a list of ARIBAS keywords and builtin functions. The argument aribas has to be given as it stands (lower case, without quotes). symbols(user). Returns a list of currently user defined variables and functions. SEE ALSO: make_unbound #------------------------------------------------------------ ?make_unbound make_unbound(Sym): boolean; Sym must be a user defined symbol denoting a variable, constant or function. (The command symbols(user) returns a list of those symbols). make_unbound removes the binding of Sym. This can be useful if one wants to recover memory used for variables (holding e.g. big integers or long arrays) which are no longer needed. Builtin functions cannot be made unbound. Return value is true in case of success, false in case of failure. SEE ALSO: symbols #------------------------------------------------------------ ?version version(): integer; Writes the version number and the architecture, for which ARIBAS was compiled, to the terminal screen. Returns an integer, which is 100*(major version no) + (minor version no). Example: ==> version(). ARIBAS Version 1.01, Sep. 1996 (MS-DOS 386) -: 101 With the optional argument 0, the message to the screen is suppressed. Example: ==> version(0). -: 101 #------------------------------------------------------------ ?var var Variable declarations: In ARIBAS, variables may be declared at top level or inside function definitions. For example, the following is a top level declaration of an integer x and an array vec of length 100. ==> var x: integer; vec: array[100]; end. -: var Inside function definitions, the end of the variable declaration is marked by the symbol begin which denotes the start of the function code. Note: At top level, variable declarations are not obligatory since variables can be created by assignments. However inside function definitions all used variables have to be declared. SEE ALSO: procedure, const, external, begin #------------------------------------------------------------ ?const const Constant declarations: In ARIBAS, constants may be declared at top level or inside function definitions. For example, the following is a top level declaration of an integer constant Bound with value 2**16 and a constant array Weekdays of strings; ==> const Bound = 2**16; Weekdays = ("SU", "MO", "TU", "WE", "TH", "FR", "SA"); end. -: const Inside function definitions, the end of the constant declaration is not marked by the symbol end but either by the symbol var (begin of a variable declaration) or by the symbol begin (start of the function code). SEE ALSO: var #------------------------------------------------------------ ?external external In ARIBAS, all global variables which are used inside a function definition, have to be declared as external. The external declaration comes first, before the constant and variable declaration. As an example, suppose that there exists a global integer variable Counter. This can be used in the following way to count how often the function foo is called: function foo(vec: array of real): real; external Counter: integer; var len: integer; begin inc(Counter); len := length(vec); return product(vec)**(1/len); end. SEE ALSO: procedure, function, var #------------------------------------------------------------ ?type type The user may define her own types in top level type declarations. For example, the following type declaration ==> type vector = array[3] of real; item = record key: integer; name: string; data: byte_string; end; end. -: type defines a type vector denoting an array of 3 reals and a type item which denotes a record with 3 fields (of type integer, string and byte_string respectively). After such a type declaration (which can occur only at top level), the newly defined types can be used at top level and inside functions in the same way as the builtin data types of ARIBAS. SEE ALSO: record #------------------------------------------------------------ ?record A record is a structured data type consisting of several components (called fields) which may have different types. Records can be defined in (top level) type declarations, for example type item = record key: integer; data: byte_string[8]; end; end; declares a type item which is a record with two fields, named key and data. After this type declaration a variable declaration var xx: item; end; creates a record of type item. The fields of this record are then xx.key and xx.data. The first is an integer and the latter a byte_string of length 8, so that an assignment of the following form is possible: xx.data[5] := 127 SEE ALSO: type, pointer #------------------------------------------------------------ ?pointer pointer to ; The pointer syntax in ARIBAS is as in Modula-2, however only pointers to records exist. Pointers can be used to construct dynamical data types. For example, a linked list of strings can be defined using the following type declaration. type list = pointer to item; item = record name: string; next: list; end; end; If after this type declaration a pointer variable of type list is defined in a variable declaration like var LL: list; end; then LL does not yet point to a record of type item, but is initialized with the value nil. In order to make LL point to an actual record, the procedure new has to be used. SEE ALSO: record, new, nil #------------------------------------------------------------ ?nil nil Constant which can be assigned to any pointer variable. In ARIBAS all pointer variables are initialized with the value nil. To make a pointer variable point to an actual record, the procedure new has to be used. SEE ALSO: pointer, new #------------------------------------------------------------ ?new new(var ptr: pointer to ): ; If ptr is a variable of type pointer to a certain record type, then new(ptr) creates a new record of that type and makes ptr point to this record. For example, after the variable declaration var ptr: pointer to record x,y,w,h: integer; end; end; ptr has the value nil. Calling ==> new(ptr). -: &(0, 0, 0, 0) produces a record with 4 integer fields ptr^.x, ptr^.y, ptr^.w and ptr^.h, which can also be used as left hand sides in assignments, for example ==> ptr^.x := ptr^.y := 10; ptr^.w := 512; ptr^.h := 360. -: 360 ==> ptr^. -: &(10, 10, 512, 360) SEE ALSO: pointer, record, nil #------------------------------------------------------------ ?function data type function User defined functions and builtin functions (with the exception of write, writeln) can be assigned to variables and used as arguments of other functions. Example: ==> F := (cos,sin,tan). -: (cos, sin, tan) ==> for i := 0 to length(F)-1 do fun := F[i]; writeln(fun(pi/6)); end. 0.866025404 0.500000000 0.577350269 function (and it's synonym procedure) is also the keyword introducing a function definition, see description under procedure. SEE ALSO: procedure #------------------------------------------------------------ ?procedure function, procedure The keyword function (or it's synonym procedure) introduces a function definition, which has the form function (): ; begin end; The external, constant and variable declarations may also be absent. Example: function foo(x,n: integer): integer; var i: integer; begin for i := x+1 to n do x := x*i; end; return x; end; SEE ALSO: external, const, var, begin, return, function #------------------------------------------------------------ ?return return ; A return statement can appear in the body of a function definition (this body is delimited by the symbols begin and end). must be an expression evaluating to an object of data type equal to the result type of the function. If during a function call the evaluation reaches the return statement, the value of is returned immediately as the result of the function call. In ARIBAS, the result type of a function may also be a structured type like an array. Example: function foo(x: integer): array[3]; var x2: integer; begin x2 := x*x; return (x,x2,x2*x); end; SEE ALSO: procedure, function, begin #------------------------------------------------------------ ?begin ?end begin end; Inside a function definition the keyword begin indicates the start of the function body. The function body and at the same time the function definition ends with the keyword end. Example: function fac(n: integer): integer; var x, i: integer; begin x := 1; for i := 2 to n do x := x*i; end; return x; end; SEE ALSO: procedure, function #------------------------------------------------------------ ?ARGV ARGV: array of string; If you call aribas with command line arguments, aribas [options] ... where is a file with ARIBAS source code, then ARIBAS will load this file and the vector ARGV will contain the elements , , ..., as strings. Suppose for example you have a file startup.ari in the current directory and call aribas -q startup 4536 eisenstein then ARGV = ("startup", "4536", "eisenstein"). If you need some arguments as numbers and not as strings, you can transform them by atoi (or atof); in our example x := atoi(ARGV[1]) will do it. The length of the vector ARGV can be determined by length(ARGV). SEE ALSO: atoi, atof, length #------------------------------------------------------------ ?_ ?__ ?___ - -- --- The symbols _, __ and ___ are pseudo variables which contain the three most recent results. For example, ==> 2**10. -: 1024 ==> _**2. -: 1048576 ==> _*__. -: 1073741824 ==> ___*__*_. -: 1152_92150_46068_46976 #------------------------------------------------------------ (************************* EOF *****************************) aribas165b/doc/aribas.man0000644000076600000240000004565614660570652014324 0ustar ottostaffARIBAS(1) ARIBAS(1) NAME aribas - Multiprecision Arithmetic Interpreter SYNOPSIS aribas [options] [ [ ...]] This man page was written for Debian since the orginal software did not contain a man page. DESCRIPTION Aribas is an interactive interpreter suitable for big integer arithmetic and multiprecision floating point arithmetic. It has a syntax similar to Pascal or Mod­ ula-2, but contains also features from other programming languages like C, Lisp, Oberon. USAGE The simplest way to use aribas is as a calculator for (big integer) arithmetic. After aribas is started, it displays a prompt ==> and is ready to accept input. Simply enter the expression you want to calculate, followed by a full stop, and then press RETURN, for example ==> 123 + 456*789. Aribas answers -: 359907 The symbol -: introduces the result. IMPORTANT. To mark the end of your input, you must always type a full stop `.' and then press RETURN. You can assign the result of a calculation to a variable, as in ==> F6 := 2**64 + 1. -: 18446_74407_37095_51617 This calculates the 6th Fermat number (** denotes exponen­ tiation) and assigns it to the variable F6 (note that aribas is case sensitive, so this is not the same as f6). Later you can use this variable for example in the expres­ sion ==> 123**(F6 - 1) mod F6. -: 688_66214_58712_63971 which shows (by Fermat's theorem) that F6 is not a prime number. The three most recent results are stored in the pseudo variables _, __, and ___. For example you can store the last result in the variable x by the command ==> x := _. -: 688_66214_58712_63971 As you can see in the above examples, aribas uses the underscore _ to structure the output of big integers (>= 2**32). Also for input of integers you may use the under­ score, the only condition is that immediately before and after the underscore there are digits, example: ==> z := 123_4567_890. -: 1234567890 Here the output contains no underscore, which shows that z is less than 2**32. Aribas has several built-in functions for factorization, for example rho_factorize, which uses Pollard's rho algo­ rithm. ==> rho_factorize(F6). working .. factor found after 512 iterations -: 274177 To find the remaining cofactor, give the command ==> x := F6 div _. -: 6728_04213_10721 To test whether this factor is prime, Rabin's probabilis­ tic test rab_primetest can be applied: ==> rab_primetest(x). -: true The function rho_factorize is good for finding small fac­ tors (say up to 10 decimal digits); for more complicated factorization tasks a more powerful algorithm like the quadratic sieve qs_factorize should be used ==> qs_factorize(2**128+1). (Depending on the power of your computer, it will take a few seconds up to a few minutes to get a prime factor of the 7th Fermat number.) Control structures The for loop and the while loop in aribas have a syntax as in Modula-2. For example, the following command sequence calculates the factorial of 100. ==> x := 1; for i := 2 to 100 do x := x*i; end; x. As you can see in this example, the input may extend over several lines. The above for loop is equivalent to the following while loop ==> x := 1; i := 2; while i <= 100 do x := x*i; inc(i); end; x. The branching construct if ... then ... elsif ... else ... end has also the same syntax as in Modula-2. Multiprecision floating point arithmetic Aribas supports different types of floating point numbers which are internally represented with mantissas of differ­ ent bit-length: single_float 32 bits double_float 64 bits long_float 128 bits and several higher precisions up to an implementation dependent limit, typically 1024 or 4096 bits, which can be determined by the function max_floatprec(). By default, when calculating with numbers of data type real, sin­ gle_floats are used. This corresponds to a precision of 9 to 10 decimal places. A precision of 4096 bits corre­ sponds to over 1200 decimal places. The precision can be changed using the function set_float­ prec. The function takes one integer argument, which is the desired precision in bits. It is automatically rounded to the next higher available value. For example, after ==> set_floatprec(100). -: 128 the floating point precision is 128 bits and you can cal­ culate ==> arctan(sqrt(3)). -: 1.04719_75511_96597_74615_42144_61093_16762_8 ==> _/pi. -: 0.33333_33333_33333_33333_33333_33333_33333_33 User defined functions The user can define his or her own functions. A typical example looks like ==> function fac(n: integer): integer; var x,i: integer; begin x := 1; for i := 2 to n do x := x*i; end; return x; end. If you have entered this correctly, aribas echoes the function name -: fac and from now on you can use fac in the same way as a built-in function, e.g. ==> fac(32). -: 2_63130_83693_36935_30167_21801_21600_00000 Note that inside function definitions all used variables must be explicitly declared, whereas on top level of the aribas interpreter variables can be simply created by assignments. Here is another example, which shows some other data types supported by aribas: ==> function sqrt_list(n: integer): array of real; var vec: array[n] of real; i: integer; begin for i := 1 to n do vec[i-1] := sqrt(i); end; return vec; end. This function returns an array of the square roots of the integers from 1 to n, for example ==> sqrt_list(10). -: (1.00000000, 1.41421356, 1.73205081, 2.00000000, 2.23606798, 2.44948974, 2.64575131, 2.82842712, 3.00000000, 3.16227766) In a bigger programming project where you need several functions you would not enter them directly at the aribas prompt but prepare the function definitions with an exter­ nal text editor and save them in a file with the exten­ sion .ari , for example abcd.ari . This file can then be loaded by aribas using the command ==> load("abcd"). If there is a syntax error in the file, you get an error message of the form error in line <= 23 of loaded file if: end expected which tells you (in this example) that there is an error in the if construct in line 23 or earlier in the file. (Note that the error messages are sometimes not very pre­ cise.) You can then correct the error and load the file again. Online help The command ==> symbols(aribas). returns a list of all keywords and names of builtin func­ tions of aribas. This list has about 180 entries, and begins and ends as follows: (ARGV, _, __, ___, abs, alloc, and, arccos, arcsin, arc­ tan, arctan2, aribas, array, atof, atoi, begin, binary, bit_and, bit_clear, bit_length, ...... , tolower, toupper, transcript, true, trunc, type, user, var, version, while, write, write_block, write_byte, writeln) For most of the symbols in this list, you can get a short online help using the function help(). For example, the command ==> help(ARGV). gives an information on the builtin variable ARGV, whereas ==> help(while). describes the syntax of the while loop. If you need more information than that contained in the online help, con­ sult the documentation which can be found in /usr/share/doc/aribas. How to exit To end an aribas session, type exit at the aribas prompt ==> exit and then press the RETURN (ENTER) key. If you don't want to leave aribas, but want to break out of an infinite loop or a calculation that lasts too long, type CONTROL-C (if you are running aribas from within Emacs, you must press CONTROL-C twice). This will (in most cases) stop the current calculation and return to the aribas prompt. When you are not using the Emacs interface but the command line version of aribas, you sometimes get into the follow­ ing situation: Some previous line contains a typing error, but you cannot return to that line to correct it. In this case you should simply type a full stop `.' , followed by RETURN. You will get an error message which you can safely ignore, and a new prompt ==> appears, allowing you to try again. COMMAND LINE ARGUMENTS aribas [options] [ [ ...]] options The following options are available: -q (quiet mode) Suppresses all messages to the screen (version no, copyright notice, etc.) when aribas is started -v (verbose mode, default) Does not suppress messages to the screen when aribas is started. -c aribas does its own line breaking when writing to the screen. Normally it supposes that the screen (or the window in which aribas runs) has 80 columns. With the -c option you can set another number, which must be between 40 and 160 (in deci­ mal representation). For example, if you run aribas in an Xterm window with 72 columns, use the option -c72 (or -c 72, the space between -c and the number is optional). -m Here is a number (in decimal representation) between 64 and 16000. This number indicates how many Kilobytes of RAM aribas should use for the aribas heap. The default value depends on the options used when aribas was compiled. Typically, under UNIX or LINUX it is 6 Megabytes, correspond­ ing to -m6000 -h The online help of aribas depends on a file aribas.hlp which should be situated in the range of the environment variable PATH. If this is not the case you can specify the exact path of the help file with the -h option. If for example the file aribas.hlp is in the directory /usr/local/lib, use the option -h /usr/local/lib (the space after -h is not necessary). The -h option can also be used if the help file has a different name. If the help file is named help-aribas and lies in the directory /home/joe/ari, use -h/home/joe/ari/help-aribas. With a properly installed Debian package of aribas it should not be necessary to use this option. -p With this option you can specify a search path for loading files with aribas source code. may be either the (absolute) pathname of one directory or several pathnames separated by colons. Suppose that you have called aribas with the option -p/usr/local/lib/aribas:~/ari/examples and that your home directory is /home/alice/. Then the command ==> load("factor"). will search the file factor.ari first in the cur­ rent directory, then in the directory /usr/local/lib/aribas and finally in /home/alice/ari/examples. -b Batch mode when loading an aribas source code file from the command line, see below. One letter options which require no arguments may be merged, for example aribas -q -b is equivalent to aribas -qb Further command line arguments The next command line argument after the options is interpreted as the name of a file with aribas source code. If the file name has the extension .ari, this extension may be omitted. The file is loaded as if the command load("") had been given after the start of aribas at the aribas prompt. If the file is not found in the current directory it is searched in the directories speci­ fied by the -p option. If the option -b was given, the file is loaded and executed. Afterwards aribas exits without showing it's prompt. If the file can­ not be loaded completely because of an error, aribas exits immediately after the error message. ... When further command line arguments follow , they are collected (as strings) together with in the vector ARGV which can be accessed from within aribas. Example: If you call aribas with the command line aribas startup 4536 eisenstein and the current directory contains the file startup.ari, then aribas loads it and the vector ARGV has the form ==> ARGV. -: ("startup", "4536", "eisenstein") If you need some arguments as numbers and not as strings, you can transform them by atoi (or atof); in our example ==> x := atoi(ARGV[1]). -: 4536 will do it. The length of the vector ARGV can be determined by length(ARGV). RUNNING ARIBAS WITHIN EMACS You can run aribas from within Emacs by giving the command (in Emacs' minibuffer) M-x run-aribas (If you don't have a META key, use ESC x instead of M-x) Then aribas will be loaded into an Emacs window with name *aribas* and you can edit your input to aribas with the usual Emacs commands. If your input ends with a full stop '.' and you press RETURN, it is sent to aribas. If however your complete input does not end with a full stop, (for example in response to a readln), the input is sent to aribas by C-j (Control-j) or C-c RETURN. If you want to repeat a previous input, M-p (or ESC p) cycles backward through input history, and M-n (or ESC n) cycles forward. A Control-C is sent to aribas by C-c C-c (press C-c twice). It is also possible to start aribas from Emacs with com­ mand line arguments. For this purpose the command C-u M-x run-aribas has to be given. Then a prompt run-aribas: aribas appears in the Minibuffer of Emacs and you can complete the command line, for example run-aribas: aribas startup 4536 eisenstein (see above). CONFIGURATION FILE Options for running aribas can be specified also using a configuration file with name .arirc. Aribas searches for a configuration file in the following order: 1) the current directory 2) the home directory of the user There is a third possibility: You can define an environ­ ment variable ARIRC containing the name of the configura­ tion file (which may be different from .arirc), including the full path. In the configuration file you can specify all command line options described above which begin with a - sign, however a separate line must be used for every single option. Lines beginning with the character # or empty lines are ignored. In addition to the options described above, the configuration file may contain aribas source code. For this purpose there must be a line reading -init Then everything after this line is treated as aribas source code and executed when aribas is started. The existence of a configuration file for aribas does not exclude the possibility to give command line arguments. If an option (e.g. the -m option) is specified both in the configuration file and the command line but with different values, then the specification at the command line is valid. Analogously, a -v option on the command line over­ rides a -q option in the configuration file. If there is -init code in the configuration file and an argument at the command line, then the -init code is exe­ cuted first and afterwards the is loaded and its code executed. FILES $ARIRC, .arirc, $HOME/.arirc Optional configuration file. ENVIRONMENT VARIABLES $ARIRC Location of the optional configuration file. SEE ALSO emacs(1) More information on how to use aribas can be found in /usr/share/doc/aribas. The aribas home page is http://www.mathematik.uni- muenchen.de/~forster/sw/aribas.html. BUGS Bug reports should be sent by email to forster@mathematik.uni-muenchen.de AUTHOR Otto Forster is the author of the aribas program. This man page was compiled by Ralf Treinen from the aribas docu mentation for the Debian package of aribas, and supple­ mented by the author. ARIBAS February 2001 aribas165b/doc/aridoc.txt0000644000076600000240000036453114660570651014363 0ustar ottostaffFile aribas.doc DOCUMENTATION of the ARIBAS interpreter for Arithmetic, Version 1.65, September 2018 Copyright (C) 1996-2018 O.Forster ARIBAS is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de WWW http://www.mathematik.uni-muenchen.de/~forster The latest version of ARIBAS can be obtained via the homepage of the author (*-------------------------------------------------------------------*) Date of last change of this documentation: 1997-04-22: added sections on records and pointers, configuration file 1997-07-06: option -b, readln and multi-line integers 1997-08-19: getenv; removed create_array; added information on load 1998-10-19: qs_factorize, next_prime, continue 1999-04-30: quiet option for qs_factorize et al. 2002-03-03: max_floatprec, vector operations 2003-06-09: Simultaneous Assignment, divide, bit_count, gmtime, set_workdir, get_workdir, realloc, stack2string, stack_arraypush, string_scan, binsearch 2002-11-08: ec_factorize 2004-08-07: gfp_sqrt, arithmetic in GF(2**n) 2008-08-20: polynomials over GF(2) 2018-09-20: minor changes (*-------------------------------------------------------------------*) Contents 1) INTRODUCTION 2) IDENTIFIERS 3) DATA TYPES 4) OPERATORS, EXPRESSIONS 5) VARIABLE DECLARATIONS 6) TYPE DEFINITIONS, RECORDS, POINTERS 7) CONTROL STRUCTURES 8) FUNCTION REFERENCE a) Functions for integer arithmetic a1) Functions for arithmetic in GF(2**n) a2) Polynomials over GF(2) b) Functions for real arithmetic and analysis c) Random d) Characters, strings e) Byte_strings f) Arrays, records g) Stacks h) In/Out i) System functions 9) USER DEFINED FUNCTIONS 10) COMMAND LINE ARGUMENTS (*-------------------------------------------------------------*) 1) INTRODUCTION =============== ARIBAS is an interactive Interpreter suitable for big integer arithmetic and multiprecision floating point arithmetic. It has a syntax similar to Pascal or Modula-2, but contains also features from other programming languages like C, Lisp, Oberon. After ARIBAS is started, it displays a prompt ==> and you may input an expression you want to calculate. You must mark the end of the input by a full stop '.' and then press the RETURN key. Examples: ==> 2*3 + 17. -: 23 ==> 2**1000. -: 10_71508_60718_62673_20948_42504_90600_01810_56140_48117_05533_60744_37503_ 88370_35105_11249_36122_49319_83788_15695_85812_75946_72917_55314_68251_87145_ 28569_23140_43598_45775_74698_57480_39345_67774_82423_09854_21074_60506_23711_ 41877_95418_21530_46474_98358_19412_67398_76755_91655_43946_07706_29145_71196_ 47768_65421_67660_42983_16526_24386_83720_56680_69376 The operator ** denotes exponentiation (as in FORTRAN). The symbol -: introduces the result of a calculation. You may also input several expressions separated by semicolons, for example ==> x := 3; y := 4; z := sqrt(x*x + y*y). -: 5.00000000 There are also control structures available, e.g. the for-loop which has a syntax similar to Modula-2 ==> for k := 2 to 10 do writeln(k:3,log(k):12:6); end. 2 0.693147 3 1.098612 4 1.386294 5 1.609438 6 1.791759 7 1.945910 8 2.079442 9 2.197225 10 2.302585 In this example the natural logarithms of the integers from 2 to 10 were displayed as a side effect of the writeln command (which allows format options as in Pascal). The for-loop has an empty result. You can also define your own functions, for example ==> function fac(n: integer): integer; var x: integer; begin x := 1; while n > 1 do x := x*n; dec(n); end; return x; end. -: fac The result of this input is the symbol denoting the name of the defined function. From now on, you can use this function ==> fac(100). -: 933_26215_44394_41526_81699_23885_62667_00490_71596_82643_81621_46859_ 29638_95217_59999_32299_15608_94146_39761_56518_28625_36979_20827_22375_82511_ 85210_91686_40000_00000_00000_00000_00000 These examples are meant only as a first short presentation of ARIBAS. To get a practical introduction, please study the tutorial (file aritut.txt). The following is a more systematic description of ARIBAS. 2) IDENTIFIERS ============== Identifiers (names of variables, functions and data types) may be composed of the letters from a to z and A to Z, the digits 0 to 9, and the underscore _. The first character of an identifier cannot be a digit. Examples of admissible identifiers: x x1 _alfa1 lower_bound maxSize Examples of inadmissible identifiers are 1alpha, beta.2 or gamma_$3. Identifiers may not contain embedded spaces and may not extend over several lines. Otherwise the length is arbitrary. All characters of the identifier are significant. ARIBAS is case sensitive, so maxSize and maxsize are different identifiers. Identifiers of user defined variables, functions and data types must be different from the keywords of ARIBAS and from the names of builtin functions and procedures. One can get a list of these reserved names by the command ==> symbols(aribas). -: (ARGV, _, __, ___, abs, alloc, and, arccos, arcsin, arctan, arctan2, aribas, array, atof, atoi, begin, binary, binsearch, bit_and, bit_clear, bit_count, bit_length, bit_not, bit_or, bit_set, bit_shift, bit_test, bit_xor, boolean, break, by, byte_string, cardinal, cf_factorize, char, chr, close, concat, const, continue, cos, dec, decode_float, div, divide, do, double_float, else, elsif, end, even, exit, exp, extended_float, external, factor16, factorial, false, file, float, float_ecvt, floor, flush, for, frac, ftoa, function, gc, gcd, gcdx, get_filepos, get_floatprec, get_printbase, get_printprec, get_workdir, getenv, gmtime, halt, help, if, inc, integer, isqrt, itoa, jacobi, length, load, log, long_float, make_unbound, max, max_arraysize, max_floatprec, max_intsize, mem_and, mem_bclear, mem_bitswap, mem_bset, mem_btest, mem_byteswap, mem_not, mem_or, mem_shift, mem_xor, memavail, min, mod, mod_coshmult, mod_inverse, mod_pemult, new, next_prime, nil, not, odd, of, open_append, open_read, open_write, or, ord, pi, pointer, prime32test, procedure, product, qs_factorize, rab_primetest, random, random_seed, read_block, read_byte, readln, real, realloc, record, return, rewind, rho_factorize, round, set_filepos, set_floatprec, set_printbase, set_printprec, set_workdir, sin, single_float, sort, sqrt, stack, stack2array, stack2string, stack_arraypush, stack_empty, stack_pop, stack_push, stack_reset, stack_top, stderr, stdin, stdout, string, string_scan, string_split, substr_index, sum, symbols, system, tan, then, timer, to, tolower, toupper, transcript, true, trunc, type, user, var, version, while, write, write_block, write_byte, writeln) The symbols _, __ and ___ are system variables which contain the three last results. Example: ==> sqrt(2). -: 1.41421356 ==> sqrt(_). -: 1.18920711 ==> sqrt(_). -: 1.09050773 ==> _ * __ * ___. -: 1.83400808 ==> _ ** (8/7). -: 2.00000000 Here we calculated the square root of 2, the fourth and the eighth root of 2 and multiplied the three results. This gives 2 to the power 7/8. Therefore, if we exponentiate by 8/7, we must get back the number 2. Comments -------- Text between the symbols (* and *) is considered by ARIBAS as a comment and is ignored. Comments may extend over several lines. Nested comments are not allowed. There is another possibility to insert short comments: Text between the hash character # and the line end is also ignored by ARIBAS. 3) DATA TYPES ============= ARIBAS supports the following data types integer real boolean char string byte_string gf2nint array stack file function record pointer (*----------------------------------------------------------------*) integer The data type integer comprises the whole numbers 0, 1,-1, 2,-2, 3,.... ARIBAS can handle integers up to 20000 or more decimal digits, see function max_intsize() in the function reference. Integer literals are given by an optional sign and a sequence of decimal digits. For better reading, this sequence of digits may be subdivided by underscores. In this case, immediately before and immediately after the underscore _, there must be a digit. Examples of integer literals: 1 1234567890 -3456_78965_12367 Besides the decimal representation of integers, ARIBAS allows also integer literals with respect to base 2, 8 or 16. For base 2, the sequence of binary digits (0 and 1) must be preceded by the prefix 0y. The prefix for basis 8 is 0o. For basis 16, the sequence of hexadecimal digits (0 ... 9, A ... F) must be preceded by 0x. (The hexadecimal digits A ... F may also be written in lower case.) An optional sign comes before the base prefix. Examples: 0y111101 0o177 0xfffff_ffffe -0x123456789ABCDEF (*----------------------------------------------------------------*) real The data type real comprises a computer approximation of the real numbers. Real literals are given in decimal representation, beginning with an optional sign + or -, then a non-empty sequence of decimal digits, an obligatory decimal point, a second non-empty sequence of decimal digits and an optional scaling factor, consisting of the symbol E (or e), an optional sign and a non-empty sequence of decimal digits. Examples: 0.3 +3.1e-45 -0.00007E1000 The following forms are not admissible real literals: .333 333e-3 (The number which is meant by these symbols may be represented by 0.333 or 333.0e-3). Internally, numbers of type real are stored in binary representation (see function decode_float in the function reference). This implies for example, that even a simple number like 0.1 cannot be represented exactly. The precision used for the calculations with real numbers depends on the current floating point precision. By default, ARIBAS uses a mantissa of 32 bits (which corresponds to 9-10 decimal digits), but the user may set the precision to a higher value (up to 4096 binary digits), using the builtin function set_floatprec. For details, see the function reference. (*----------------------------------------------------------------*) boolean The data type boolean comprises the truth values false and true. The logical operators not, and, or apply to boolean operands in the usual way and yield boolean results. Boolean values are also the result of arithmetic relational operators. In every place where ARIBAS expects a boolean value (e.g. as conditions in the if or while constructions), one can also use integer values. Then the value 0 is considered as false and every nonzero integer counts as true (this is the same behaviour as in the programming language C). (*----------------------------------------------------------------*) char The data type char comprises 256 characters with code numbers 0 to 255. Characters with code numbers < 128 are the standard ASCII characters (they comprise printable characters and control characters); characters with code number >= 128 are system dependent. Character literals of printable characters are given by enclosing the symbol between single quotes, as in 'A'. The function chr translates integer values from 0 to 255 into the corresponding characters. In this way, also the non-printable characters can be represented. For example, chr(7) is the bell character (which usually generates a beep when output to the terminal), whereas chr(65) is the same as 'A'. Remark: In ARIBAS, 'A' and "A" is not the same object (in contrast to Modula-2). The latter is a string of length 1. (*----------------------------------------------------------------*) string The data type string comprises sequences of characters and serves to represent text. String literals are given by enclosing the character sequence between double quotes, as in "ABCD". A problem arises if the string itself contains a double quote, i.e. the character '"'. In this case one can use the function concat (see function reference). For example, concat("AB",'"',"CD") is the 5 character string consisting of the characters 'A', 'B', '"', 'C', 'D'. In this way one can also construct strings which contain control characters, for example concat("AB",chr(7),"CD"). One can access a single character of a string in the following way: ==> s := "abcdef"; s[3]. -: 'd' The indexing begins with 0, the last character of a string has index n-1, where n is the length of the string. (*----------------------------------------------------------------*) byte_string A byte_string consists of a finite sequence of bytes (a byte is an 8-bit integer x, 0 <= x < 256). This is essentially the same as the Pascal notion of packed array of byte. A byte_string literal is written in the form $XXXXXX....XX, where XX stands for the hexadecimal representation of a byte. The underscore _ may be used for subdivision to increase readability. For example, ==> B := $0080_12FF78. -: $0080_12FF_78 defines a byte_string of length 6. One can access the components of the byte_string in the same way as in the case of strings. ==> B[1]. -: 128 ==> B[3]. -: 255 byte_strings can be written to binary files and read from binary files (functions write_block and read_block, see function reference). Thus byte_strings serve for data exchange between ARIBAS and the outside world. There exist transformation functions from integers to byte_strings and vice versa (functions byte_string, integer and cardinal, see function reference). (*----------------------------------------------------------------*) gf2nint gf2nint is the data type of elements of the fields GF(2**n) of characteristic 2. These fields are supported directly by ARIBAS. To be able to do arithmetic in GF(2**n), the field must be initialized by the command ==> gf2n_init(n). If no initialization is done, the field GF(2**8) is used by default. The admissible range for the degree n of the field extends from 2 to an implementation dependend limit, which can be queried with the function max_gf2nsize() and which is typically about 4000. The field GF(2**n) is represented as GF(2)[X]/(f(X)), where f(X) is an irreducible polynomial of degree n. The elements of GF(2**n) are represented by polynomials of degree < n with coefficients 0 or 1, i.e. by bitvectors of length <= n. Literals of data type gf2nint are marked by the prefix 2x, followed by the hexadecimal representation of this bitvector. For example, in the field GF(2**8), the element 2x8A represents the class of the polynomial X**7 + X**3 + X, since 2**7 + 2**3 + 2 = 138 = 0x8A. Also binary and octal representations are admissible; these are marked with the prefixes 2y and 2o respectively. For example, 2x8A = 2y10001010 = 2o212. The zero element of GF(2**n) is 2x0 = 2y0 = 2o0; the unit element is 2x1 = 2y1 = 2o1. For elements of data type gf2nint the following oprations are available: x + y, x*y, x/y Addition, multiplication, division (denominator must be different from zero). Since we are in characteristic 2, subtraction x-y is the same as addition. x**n Exponentiation: x is a gf2nint, n an integer. The exponent may be negative. In this case x must be different from zero. x**-1 is the same as 2x1/x. See also the description of the functions gf2nint(x: integer): gf2nint; integer(x: gf2nint): integer; max_gf2nsize(): integer; gf2n_init(deg: integer): integer; gf2n_fieldpol(): integer; gf2n_degree(): integer; gf2n_trace(z: gf2nint): integer; in the function reference. (*----------------------------------------------------------------*) array of Type The array is a structured data type, consisting of finite sequences of components of a given (but arbitrary) data type Type. Array literals are given by a comma separated list of its components. The list is enclosed between a pair of parentheses ( and ), for example vec := (37, 41, -9). However, for arrays of length 1, braces must be used. vec1 := {37}. The expression (37) is interpreted by ARIBAS as the number 37. One may use braces instead of parentheses also for arrays of length > 1. The components of an array vec can be accessed as vec[i] where 0 <= i < length(vec). Besides accessing single components, one can also access whole subarrays. If vec is an array, then vec[n1..n2] denotes the subarray consisting of all components vec[i] with n1 <= i <= n2. Example: ==> vec := (1,2,3,4,5,6,7,8,9,10). -: (1, 2, 3, 4, 5, 6, 7, 8, 9, 10) ==> vec[2..6]. -: (3, 4, 5, 6, 7) The upper bound may be omitted: vec[n1..] is equivalent to vec[n1..length(vec)-1]. Subarrays may also appear at the left hand side of assignments and thus allow the simultaneous modification of several components. Example: Let vec the above array. Then ==> vec[2..6] := (0,-1,-2,-3,-4). -: (0,-1,-2,-3,-4) changes vec to ==> vec. -: (1, 2, 0, -1, -2, -3, -4, 8, 9, 10) The subbarray feature applies also analogously to strings and byte_strings. (*----------------------------------------------------------------*) stack There is a predefined data type stack in ARIBAS. Functions operating on stacks are stack_push, stack_pop, stack_top, stack_reset, stack_empty, stack2array and length (see function reference). Stacks can be used for example to temporarily store objects (of arbitrary data type) if the total number is not known in advance (e.g. the prime factors of an integer). (*----------------------------------------------------------------*) file Data type file: ARIBAS supports text files and binary files. See function reference, subsection In/Out. (*----------------------------------------------------------------*) function Data type function: User defined functions and builtin functions (with the exception of write, writeln) can be assigned to variables and used as arguments of other functions. Example: ==> F := (cos,sin,tan). -: (cos, sin, tan) ==> for i := 0 to length(F)-1 do fun := F[i]; writeln(fun(pi/6)); end. 0.866025404 0.500000000 0.577350269 (*----------------------------------------------------------------*) record, pointer Besides the builtin data types, one can define new data types, using records and pointers. See below section 6) Type definitions, records, pointers (*----------------------------------------------------------------*) 4) OPERATORS, EXPRESSIONS ========================= The assignment operator := -------------------------- An assignment has the following form := The expression is evaluated and assigned to . In general, is simply an identifier, but may also be an array component, a subarray or a record field. Examples: ==> vec := (1,2,3,4). -: (1, 2, 3, 4) ==> vec[2] := 10. -: 10 ==> vec. -: (1, 2, 10, 4) The data type of must be assignment compatible to the data type of . On top level (i.e. outside function definitions), may also be an undeclared identifier. Then the assignment is implicitly also a declaration of a variable of the proper data type. The assignment as a whole is an expression, whose value is the value of . The assignment operator is right associative (as in C). Therefore multiple assignments like the following are possible: := := In assignments of arrays (e.g. vec1 := vec2) a new copy of the right hand side (vec2 in the example) is constructed and assigned (unlike the situation in C, this is not an assignment of pointers). Arrays of different lengths are assignment compatible. Examples: ==> vec1 := (1,2,3). -: (1, 2, 3) ==> vec2 := (4,5,6,7). -: (4, 5, 6, 7). Now, the assignment vec1 := vec2 is possible: ==> vec1 := vec2. -: (4, 5, 6, 7). If we change vec2, ==> vec2[2] := -1. -: -1 the value of vec1 is untouched. ==> vec2. -: (4, 5, -1, 7) ==> vec1. -: (4, 5, 6, 7) Simultaneous Assignment ----------------------- (,,...,) := (,,...,) The expressions ,,..., are evaluated and then assigned to the variables ,,..., respectively. For example, this can be used to swap two variables: ==> x := pi. -: 3.14159265 ==> y := exp(1). -: 2.71828183 ==> (x,y) := (y,x). -: (2.71828183, 3.14159265) ==> x. -: 2.71828183 ==> y. -: 3.14159265 Without simultaneous assignment, you would have to use a temporary variable: ==> temp := x; x := y; y := temp. As another example, consider the following compact code to calculate the Fibonacci numbers. ==> function fibo(N: integer): integer; var u,v,k: integer; begin (u,v) := (1,0); for k := 1 to N do (u,v) := (v,u+v); end; return v; end. -: fibo ==> fibo(100). -: 3_54224_84817_92619_15075 A more complicated example of swapping: ==> vec := (1,2,3,4,5). -: (1, 2, 3, 4, 5) ==> (vec[0..2],vec[3..4]) := (vec[2..4],vec[0..1]). -: ((3, 4, 5), (1, 2)) ==> vec. -: (3, 4, 5, 1, 2) Arithmetical operators ---------------------- +, -, *, **, /, div, mod + and - are unary operators (if used as prefix) and binary operators (if used infix). As binary operators, they are left associative. The operands may be integers or reals. If one of the operands is an integer and the other operand is a real, an implicit conversion of the integer to a real number takes place. * denotes multiplication. It is a binary left associative infix operator, which may also be applied to integers or reals. ** is the exponentiation operator. It is a binary, right associative infix operator. The operands may be integers or reals. If in the expression x**y the basis x is an integer and the exponent y is a non-negative integer, the result is again an integer; in all other cases the result is real. If the exponent is negative, the basis must be non-zero. If the exponent is a real, the basis must be positive. The binary, left associative infix operator / denotes floating point division. The operands may be integers or reals; the result is always a real. Division by zero is not allowed. div and mod are binary, left associative infix operators which may be applied only to integers and give an integer result. x div y returns the greatest integer less than or equal to x/y. The operator mod is defined by the equation x = (x div y) * y + (x mod y) The divisor y must be non-zero. Vector operations ----------------- The operators +, -, *, div and mod may also be applied to vectors, namely in the following forms: -vec, vec1 + vec2, vec1 - vec2, lambda*vec, vec*lambda Here vec, vec1, vec2 are arrays of integers or reals and lambda is an integer or a real. The last two forms are the multiplication of the vector vec by the scalar lambda. vec1 and vec2 need not have the same length; the shorter one is implicitely expanded to the greater length by appending zeroes. Example: ==> -(1,1) + pi*(1,2,3). -: (2.14159265, 5.28318531, 9.42477796) vec/lambda lambda must be a number /= 0. Divides all components of vec by lambda. Example: ==> (100, 200, 300, 400)/1.95583. -: (51.1291881, 102.258376, 153.387564, 204.516752) vec div N, vec mod N Here vec must be an array of integers and N an interger /= 0. If vec = (x1,x2,...,xn), the result is the vector with components xk div N resp xk mod N. Examples: ==> (100, 200, 300) div 12. -: (8, 16, 25) ==> (100, 200, 300) mod 12. -: (4, 8, 0) Relational operators -------------------- = (equal) /= or <> (not equal) < (less) <= (less or equal) > (greater) >= (greater or equal) All relational operators are binary infix operators and return a boolean value (true or false). The operators = (equal) and /=, <> (two synonyms for 'not equal') may be applied to operands of arbitrary data types. With the operators <, <=, >, >= one can compare numbers (integer or real). They can also be applied to two characters or to two strings. In the latter cases the comparision is done according to the ASCII codes of the characters. Example: ==> "Arthur" < "Anderson". -: false Boolean operators ----------------- not, and, or not is a unary prefix operator, whereas and, or are binary infix operatars. They may be applied to boolean arguments. The evaluation of the arguments of the binary operators and, or proceeds from left to right and is stopped as soon as the result is determined. Thus an expression like u > 0 and v/u < 1 is admissible, which would generate an error for u=0 if always both arguments of the and-operator were evaluated. Function calls -------------- In ARIBAS, a function call has the form foo(arg1,...,argn) where foo is the name of the function and arg1,...,argn is a comma separated list of the arguments, enclosed in parentheses. One must use parentheses even if the function has an empty argument list (as in the programming language C). The result of a function call can be used in other expressions, for example in arithmetical operations or assignments, as in sin(pi/3)**2 x := exp(2) As in C, ARIBAS allows to ignore the result of a function call and to call a function only for its side effects. Operator precedence ------------------- In complex expressions sometimes parentheses may be omitted by observing the precedence of operators. The following is a list of the various classes of operators according to decreasing binding force. 1. exponentiation operator 2. unary minus and unary plus 3. multiplication and division operators *, /, div, mod 4. binary plus and binary minus 5. relational operators 6. boolean operator not 7. boolean operators and, or 8. assignment operator For example, bvar := not x < y and y < z+u is the same as bvar := ((not (x < y)) and (y < (z+u))) (*---------------------------------------------------------------*) 5) VARIABLE DECLARATIONS ======================== Variables in ARIBAS can be created at top level by assignments of the form := If is a literal of a certain data type, then the becomes a variable of the same data type, initialized by this . But may also be an expression evaluating to an element of a certain data type. For example, the following assignments create two variables str1, str2 of data type string. str1 := "ABCDE"; str2 := itoa(2**31 - 1); Variables can also be created by explicit variable declarations. Inside function definitions, declarations of local variables are obligatory. A global (i.e. top level) variable declaration has the following form: var : ; ... : ; end Variable declarations inside function definitions are similar, only the symbol end is missing. It is replaced by the symbol begin marking the start of the function body. Here is a comma separated list of identifiers (the variable names). is a type specifier like integer real boolean char stack file or a string, array, record or pointer type, which will be discussed later. Example: ==> var n,m: integer; x: real; c1,c2: char; st: stack; end. -: var After this variable declaration there exist integer variables n, m, a real variable x, two character variables c1, c2, and a stack variable st. In ARIBAS, a variable declaration also initializes the variables. Integers are initialized by 0, reals by 0.0, characters by ' ' (the space character) and stacks by the empty stack. The default initializations can be changed using assignments in the variable declaration, as in the following example: ==> var n := 17; x := 3.2; ch := 'A'; end. -: var In this case the data types of the variables are derived from the initial values. Arrays, strings and byte_strings may be declared with or without length specification. The declaration with lengths is as in the following example: ==> var str: string[4]; bb: byte_string[8]; vec: array[10] of real; end. -: var This declaration creates a string str of length 4 (consisting of 4 space characters), a byte_string of length 8 (consisting of 8 zero bytes) and an array of reals of length 10, initialized with the elements 0.0. Please note that in ARIBAS strings, byte_strings and arrays of different length are assignment compatible. This implies, that a subsequent assignment ==> str := concat("**",str,"__"). -: "** __" is possible. If the length specification is omitted, strings or arrays of length 0 are created. ==> var str: string; bb: byte_string; vec: array; end. -: var ==> str. -: "" ==> bb. -: $ ==> vec. -: () Also in this case, subsequent assignments of strings or arrays of positive length to these variables are allowed. The length specifications of arrays (strings, byte_strings) are not required to be constants. Also expressions evaluating to non-negative integers are admissible. Example: ==> n := 5. -: 5 ==> var vec: array[2*n+1]; mat: array[n] of array[n]; end. -: var ==> vec. -: (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0) ==> mat. -: ((0, 0, 0, 0, 0), (0, 0, 0, 0, 0), (0, 0, 0, 0, 0), (0, 0, 0, 0, 0), (0, 0, 0, 0, 0)) If the data type of an array is not specified, array of integer is assumed. Constant declarations ===================== Constant declarations can be made (like variable declarations) at top level or inside function definitions. A top level constant definition has the form const Identifier1 = Val_1; .... Identifiern = Val_n; end. For constant declarations inside function definitions, the symbol end is omitted; the declarations ends either with the beginning of the variable declaration (var) or the start of the function body (begin). The values Val_k may be literals or arithmetic or functional expressions involving builtin functions or functions defined by the user before the constant declaration. Example: ==> const Bound1 = 2**16 - 1; Bound2 = round(exp(10)); end. -: const If one tries to assign a value to a constant, an error message is generated. ==> Bound1 := 2**15. := : non-constant symbol expected: Bound1 -: error In order to use Bound1 again as a variable (on top level), make_unbound must be used. ==> make_unbound(Bound1). -: true Now the assignment ==> Bound1 := 2**15. -: 32768 is possible. (*----------------------------------------------------------*) 6) TYPE DEFINITIONS, RECORDS, POINTERS ====================================== In ARIBAS, the user can define her own data types. The easiest case is to define new names for composite data types. For example, if you have to work a lot with 3-dimensional vectors and 3x3-matrices with real components, you can make the top level type declaration type vector = array[3] of real; matrix = array[3] of vector; end; After this type definition you can use these new types in variable declarations at top level or inside function definitions, for example var A: matrix; x,y: vector; end; By the way, if this variable declaration occurs immediately after the type declaration, the two declarations can be merged to type vector = array[3] of real; matrix = array[3] of vector; var A: matrix; x,y: vector; end; The new types can also be used in the formal parameter lists of function definitions or as result types of functions. For example, the following function calculates the tensor product of two vectors: function tprod(x,y: vector): matrix; var A: matrix; i,j: integer; begin for i := 0 to 2 do for j := 0 to 2 do A[i][j] := x[i]*y[j]; end; end; return A; end. In the above examples, the new types were only synonyms for already existing data types (vector for array[3] of real and matrix for array[3] of array[3] of real), so one could do also without them. Substantially new data types can be constructed using records and pointers. Records ------- A record is a structure consisting of several components which may have different data types. These components are the so called record fields, which can be accessed by field identifiers. For example, consider the following top level type and variable declaration: ==> type item = record key: integer; name: string; data: byte_string; end; var X,Y: item; end. -: var This defines a new data type item. Such an item has three components: 1) An integer in the field key, 2) a string in the field name and 3) a byte_string in the field data. Also, two variables X, Y of type item have been created. Their fields are X.key, X.name, X.data resp. Y.key, Y.name and Y.data. They have been initialized by the default initializations of the types integer, string and byte_string, namely 0, "" (the empty string) and $ (the byte_string of length zero) ==> X. -: &(0, "", $) In ARIBAS the external representation of a record is a comma separated list of its elements enclosed within &( and ). We can fill the fields of X with new values, for example ==> X.key := 3; X.name := "gamma"; X.data := $AABB_80FF. -: $AABB_80FF Now ==> X. -: &(3, "gamma", $AABB_80FF) One can work with the fields of X as with other variables of type integer, string or byte_string, e.g. ==> X.key ** 4. -: 81 ==> toupper(X.name). -: "GAMMA" ==> X.data[2]. -: 128 Records, like arrays, can be assigned as a whole. For example, after ==> Y := X. -: &(3, "gamma", $AABB_80FF) the record Y has the same content as the record X. Records can also be declared in variable declarations (at top level or inside function definitions) without previous type declarations. For example ==> var R1, R2: record x,y,w,h: integer; end; end. -: var declares two records R1, R2 (of anonymous type) with four integer fields x,y,w,h. Pointers -------- Dynamical data structures can be constructed using pointers. In ARIBAS only pointers to records exist. The syntax is as in Modula-2. For example, a linked list of strings can be defined using the following type declaration. ==> type list = pointer to item; item = record name: string; next: list; end; end. -: type (Note that in ARIBAS type declarations are allowed only at top level; however the defined types can afterwards also be used inside functions.) If after this type definition a variable of type list is defined, ==> var LL: list; end. -: var LL is a pointer which points to nowhere (in ARIBAS it is initialized with the value nil). ==> LL. -: nil We must use the procedure new to create a record (of type item) to which LL points. ==> new(LL). -: &("", nil) The return value of new is the newly created record to which LL points. This record is now accesible as LL^. ==> LL^. -: &("", nil) We can fill the name field of this item for example by ==> LL^.name := "mueller". -: "mueller" Now ==> LL^. -: &("mueller", nil) whereas ==> LL. -: (This external representation of the pointer cannot be used for assignments.) To append another item on top of the list LL of length 1, one can proceed as follows. ==> var ptr: list; end. -: var ==> new(ptr). -: &("", nil) ==> ptr^.name := "bauer". -: "bauer" ==> ptr^.next := LL. -: ==> LL := ptr. -: Now LL is a list of length 2; we have ==> LL^.name. -: "bauer" ==> LL^.next^.name. -: "mueller" Following Oberon (the successor to Modula-2), ARIBAS allows an abbreviation in dereferencing pointers: If Ptr is a pointer to a record and xx is a field identifier of this record, then Ptr^.xx may be abbreviated by Ptr.xx. So our above examples could have been written ==> LL.name. -: "bauer" ==> LL.next.name. -: "mueller" Note however the difference ==> LL.next. -: ==> LL.next^. -: &("mueller", nil) 7) CONTROL STRUCTURES ===================== if then elsif else end while do end for to by do end break (*-----------------------------------------------------------------*) The if-statement ---------------- if then elsif then else end; There may be more (or zero) elsif parts. The else part may also be absent. Example: function sign(x: real): integer; begin if x > 0 then return 1; elsif x < 0 then return -1; else return 0; end; end; (*-----------------------------------------------------------------*) The while-loop -------------- while do end; If evaluates to true, the statement sequence is executed (this can change the value of ). If is still true, is executed again. This is repeated until becomes false or the while loop is left by a return or a break statement. (*-----------------------------------------------------------------*) The for-loop ------------ for := to do end; must be an integer variable, and must be integer expressions. These are evaluated before the for loop is entered the first time. Then is executed with set to , +1, ..., . If is less than , is not executed at all and the for loop is skipped. for := to by do end; If there is an additional integer expression , this expression is also evaluated before entering the for loop. must evaluate to a non-zero integer. If is positive and >= , is executed for = + k*, k = 0,1,... as long as + k* <= . If is negative, is executed for = + k*, k = 0,1,... as long as + k* >= . Example: ==> for k := 11 to 0 by -2 do write(k,"; "); end. produces the output 11; 9; 7; 5; 3; 1; (*-----------------------------------------------------------------*) break The command break causes (as in C) the immediate exit from a for or a while loop. Example: ==> for x := 10**7+1 to 10**8 by 2 do if factor16(x) = 0 then break; end; end; x. -: 10000019 (*-----------------------------------------------------------------*) In ARIBAS there is no repeat .. until loop. Such a loop can always be substituted by a suitable while loop. (*-----------------------------------------------------------------*) 8) FUNCTION REFERENCE ===================== a) Functions for integer arithmetic =================================== max_intsize set_printbase get_printbase sum product divide odd even abs max min inc dec gcd gcdx isqrt factorial mod_coshmult mod_pemult mod_inverse jacobi factor16 prime32test rab_primetest rho_factorize cf_factorize qs_factorize ec_factorize bit operations (*----------------------------------------------------------------*) max_intsize(): integer; Returns the maximum number of decimal places of integers supported by ARIBAS. This number depends on the options when ARIBAS was compiled and is typically between 20000 and 64000. (*----------------------------------------------------------------*) set_printbase(b: integer): integer; The integer b must be one of the numbers 2, 8, 10, 16. The effect of this function is that subsequent output of integers is done in base b representation. Return value is the newly set print base. (If b is not admissible, the old print base is not altered.) Example: ==> set_printbase(8). -: 0o10 ==> 255. -: 0o377 (*----------------------------------------------------------------*) get_printbase(): integer; Returns the print base which is currently used. (*----------------------------------------------------------------*) sum(vec: array of integer): integer; sum(vec: array of real): real; product(vec: array of integer): integer; product(vec: array of real): real; Returns the sum resp. the product of all components of vec. (*----------------------------------------------------------------*) divide(x,y: integer): array[2]; Returns a pair (q,r) of integers such that q = x div y and r = x mod y. The argument \cc{y} must be non-zero. Example: ==> divide(100,7). -: (14, 2) ==> divide(-100,7). -: (-15, 5) (*----------------------------------------------------------------*) even(x: integer): boolean; odd(x: integer): boolean; Tests if x is even resp. odd. (*----------------------------------------------------------------*) max(x1,...,xn: integer): integer; max(x1,...,xn: real): real; min(x1,...,xn: integer): integer; min(x1,...,xn: real): real; Returns the maximum (resp. minimum) of the arguments x1,...,xn. (*----------------------------------------------------------------*) max(vec: array of integer): integer; max(vec: array of real): real; min(vec: array of integer): integer; min(vec: array of real): real; Returns the maximum (resp. minimum) of all components of vec. (*----------------------------------------------------------------*) abs(x: integer): integer; abs(x: real): real; Returns the absolute value of x. (*----------------------------------------------------------------*) inc(var x: integer [; delta: integer]): integer; Increases the integer variable x by delta (by default delta = 1) und returns the increased value of x. Functionally equivalent to x := x + delta. (*----------------------------------------------------------*) dec(var x: integer [; delta: integer]): integer; Decreases the integer variable x by delta (by default delta = 1) und returns the decreased value of x. Functionally equivalent to x := x - delta. (*----------------------------------------------------------*) gcd(x1,...,xn: integer): integer; Returns the greatest common divisor of the integers x1,x2,...,xn. For n = 1, one has gcd(x) = abs(x); if n = 0, then gcd() = 0. gcd(vec: array of integer): integer; Returns the greatest common divisor of all components of vec. (*----------------------------------------------------------*) gcdx(x,y: integer; var u,v: integer): integer; Returns the greatest common divisor d of x, y. At the same time, the variables u and v are set to values such that d = u*x + v*y Example: ==> gcdx(5,17,u,v). -: 1 ==> (u,v). -: (7, -2) (*----------------------------------------------------------*) mod_inverse(x, mm: integer): integer; If x and mm are reatively prime, this function returns the inverse of x modulo mm. Otherwise the return value is 0. Examples: ==> mod_inverse(17,100). -: 53 ==> mod_inverse(18,100). -: 0 (*----------------------------------------------------------*) isqrt(x: integer): integer; x must be a non-negative integer. Returns the greatest integer y such that y*y <= x. (*----------------------------------------------------------*) factorial(n: integer): integer; n must be a non-negative integer. Returns the factorial of n, (usually denoted by n!). Example: ==> factorial(8). -: 40320 (*----------------------------------------------------------*) mod_coshmult(x,s,mm: integer): integer; If x is an integer and xi a number such that cosh(xi) = x, then cosh(s*xi) is an integer for all natural numbers s. The function returns this number modulo mm. The result can be obtained by the following recursively defined (Lucas) sequence: a(0) := 1; a(1) := x; a(k+2) := 2*x*a(k+1) - a(k); The result is the number a(s) mod mm. This function is useful to implement the (p+1)-factorization method. (*----------------------------------------------------------*) mod_pemult(x,s,a,mm: integer): array[2] of integer; Let pe be the Weierstrass pe-function on the elliptic curve E(a) y*y = x*x*x + a*x*x + x and let xi be a point on the curve with pe(xi) = x. The s*xi is a point of E(a) (with respect to the abelian group structure on the elliptic curve). If s*xi is not a pole of pe, then pe(s*xi) = u/v is a rational number. (We may suppose that u and v are relatively prime.) If v is relatively prime to mm, the function mod_pemult(x,s,a,mm) returns (z,1), where z is an integer satisfying z*v = u mod mm (i.e. we have z = u/v in Z/mmZ). If v and mm have a greatest common divisor d > 1, the function returns (d,0). If s*xi is a pole of pe, the return value is (mm,0). This function is useful for the factorization with elliptic curves. (*----------------------------------------------------------*) factor16(x [,x0 [,x1]]: integer): integer; factor16(x) seeks a prime divisor p of x with p < min(2**16,x). If such a prime divisor exists, the smallest one is returned. Otherwise the function returns 0. If the optional arguments x0 resp. x0 and x1 are supplied, only prime divisors p satisfying the additional conditions p >= x0 resp. x0 <= p <= x1 are considered. Examples: ==> factor16(2**32 + 1). -: 641 ==> factor16(2**32 + 1, 642). -: 0 (*----------------------------------------------------------*) prime32test(x: integer): integer; Tests if abs(x) is a prime number < 2**32. If this is true, the function returns 1. If abs(x) < 2**32, but is not prime, 0 is returned. For abs(x) >= 2**32, the function returns -1. (*----------------------------------------------------------*) rab_primetest(x: integer): boolean; Performs the Rabin probabilistic prime test. If the function returns false, the number is certainly composite. A 'random' number x, for which factor16(x) = 0 and rab_primetest(x) = true is prime with high probability. An exception are numbers constructed purposely to fool the Rabin prime test. But also for these numbers the error probability is less than 1/4. To decrease the error probability, one can repeat the test several times. (*----------------------------------------------------------*) next_prime(x: integer): integer; Calculates the smallsest prime p >= x. If x > 2**32, p is only a prime with high probabilty; it has no prime divisors < 2**16 and has passed 10 strong pseudo prime tests with random bases. (*----------------------------------------------------------*) jacobi(a,m: integer): integer; Returns the Jacobi symbol of a over m. The module m must be an odd number; a may be an arbitrary integer, the result depends only on the residue class of a modulo m. If a and m are not relatively prime, the return value is 0, otherwise it is 1 or -1. If p is an odd prime and a not a multiple of p, then jacobi(a,p) = 1 if and only if a is a quadratic residue modulo p. (*----------------------------------------------------------*) rho_factorize(x:integer [; b: integer]): integer; Tries to factorize x using Pollard's rho-algorithm. The optional argument b is a bound for the maximal number of steps (default value b = 2**16). If the algorithm finds a factor, it is returned, in case of failure the return value is 0. The number x should be free of small prime factors (e.g. < 1000). Then, if x has a prime factor p < sqrt(x), the algorithm will in general find a factorization of x if b is a small multiple of sqrt(p). If the return value y is > 1 and < x, it is certainly a factor of x, but not necessarily prime. (*----------------------------------------------------------*) cf_factorize(x: integer [; mm: integer]): integer; Tries to factorize x using the Morrison-Brillhart continued fraction factorization algorithm. The run time does not depend on the size of the prime factors of x. (Hence, if it is known that x has small prime factors, another factorization method should be used.) If the period of the continued fraction of sqrt(x) is too short, the factorization will fail. In this case one should supply a second argument, which must be an integer mm with 1 <= mm < 1024. Then the continued fraction expansion of sqrt(mm*x) will be used. (*----------------------------------------------------------*) qs_factorize(x: integer): integer; Tries to factorize x using the multiple polynomial quadratic sieve factorization algorithm. The run time does not depend on the size of the prime factors of x. (Hence, if it is known that x has small prime factors, another factorization method like rho_factorize should be used.) In general, qs_factorize is faster than cf_factorize. (*----------------------------------------------------------*) ec_factorize(x: integer[; m: integer]): integer; Tries to factorize x by the elliptic curve method. The optional argument m is a bound for the number of elliptic curves used. If the algorithm finds a factor, it is returned, in case of failure the return value is 0. If the return value y is > 1, it is certainly a factor of x, but not necessarily prime. ec_factorize(x: integer; pbounds: array[2] [; m: integer]): integer; You may explicitely prescribe the prime bound and the bigprime bound by the second argument in form of a 2-dimensional vector pbounds = (bound1,bound2). The constant bound1 must be < 2**16 and bound2 < 2**24. The third optional argument m is the maximal number of elliptic curves used. In the following example the 8th Fermat number is factorized. ==> f8 := 2**256 + 1. -: 115_79208_92373_16195_42357_09850_08687_90785_32699_84665_64056_40394_ 57584_00791_31296_39937 ==> q := ec_factorize(f8,(8000,64000)). EC factorization, prime bound 8000, bigprime bound 64000 working .:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.: factor found with curve parameter 11693151 and bigprime 40177 -: 1_23892_63615_52897 ==> p := f8 div q. -: 93_46163_97153_57977_76916_35581_99606_89658_40512_37541_63818_85802_80321 ==> rab_primetest(q). -: true ==> rab_primetest(p). -: true The algorithm ec_factorize is best suited for large integers which have a relatively small prime factor (like f8). One can forbid the execution of the big prime variation by setting the second component in the vector pbounds equal to 0. ==> ec_factorize(2**101-1,(4000,0),200). EC factorization with prime bound 4000 working .......................................................... factor found with curve parameter 11017293 and prime bound 2816 -: 743_23392_08719 ec_factorize(x, [pbounds, m,] 0): integer; With a last argument 0, the progress report is suppressed and the algorithm works quietly. ==> ec_factorize(2**67-1,0). -: 193707721 (*----------------------------------------------------------*) gfp_sqrt(p,x: integer): integer; p must be an odd prime and x an integer which is a square modulo p, i.e. jacobi(x,p) /= -1. The function returns a square root of x modulo p, that is, a square root in the field GF(p). Example: ==> p := next_prime(10**6). -: 1000003 ==> x := 10. -: 10 ==> jacobi(x,p). -: 1 ==> y := gfp_sqrt(p,x). -: 394215 ==> y**2 mod p. -: 10 (*----------------------------------------------------------*) Bit operations for integers bit_test bit_set bit_clear bit_shift bit_not bit_and bit_or bit_xor bit_length The bit operations can be applied to all integers, positive or negative. Bit operations refer to the binary representation of integers. Negative integers are thought to be in two's complement representation, where the sign bit extends to infinity at the left hand side. For example, the bit pattern of the two's complement representation of -1 is ......11111111111111111111111111111111 (*----------------------------------------------------------------*) bit_test(x,n: integer): integer; Returns 1, if the bit in position n of x is set, otherwise returns 0. The count of positions begins with 0 (the bit i position n has weigth 2**n). For example, bit_test(x,0) = 1 if and only if x is odd. (*----------------------------------------------------------------*) bit_set(x,n: integer): integer; Sets the bit in position n of the integer x equal to 1 and returns the modified integer. Example: ==> bit_set(16,2). -: 20 (*----------------------------------------------------------------*) bit_clear(x,n: integer): integer; Clears the bit in position n of the integer x (i.e. sets it equal to 0) and returns the modified integer. Examples: ==> bit_clear(20,2). -: 16 ==> bit_clear(-1,0). -: -2 (*----------------------------------------------------------------*) bit_shift(x,n: integer): integer; The number n may be positive, negative or zero. If n >= 0, bit_shift(x,n) is a shift of the bit representation of x of n positions to the left (i.e. in direction of more significant bits); this is equivalent to a multiplication by 2**n. If n < 0, this is a shift of abs(n) positions to the right (i.e. in direction of less significant bits); equivalent to x div 2**abs(n). Examples: ==> bit_shift(-7,3). -: -56 ==> bit_shift(-7,-1). -: -4 ==> bit_shift(-7,-100). -: -1 (*----------------------------------------------------------------*) bit_not(x: integer): integer; Inverts all bits of x. Equivalent to -x-1. (*----------------------------------------------------------------*) bit_and(x,y: integer): integer; bit_or(x,y: integer): integer; bit_xor(x,y: integer): integer; Bitwise and, or resp. exclusive or of x and y. For example, bit_and(x,3) is equivalent to x mod 4. (*----------------------------------------------------------------*) bit_length(x: integer): integer; Returns the smallest natural number n such that abs(x) < 2**n (*----------------------------------------------------------------*) bit_count(x: integer): integer; Returns the number of bits equal to 1 in the binary representation of abs(x). Examples: ==> bit_count(0). -: 0 ==> bit_count(255). -: 8 ==> x := 10001. -: 10001 ==> write(x:base(2)). 100111_00010001 -: 1 ==> bit_count(x). -: 6 ==> bit_count(-x). -: 6 (*----------------------------------------------------------------*) a1) Functions for arithmetic in GF(2**n) ======================================== gf2n_init gf2n_fieldpol gf2n_degree gf2nint integer max_gf2nsize gf2n_trace (*----------------------------------------------------------*) gf2n_init(deg: integer): integer; Initializes the field GF(2**deg), which is an extension of degree deg of the field with two elements GF(2). Return value is an integer f, representing an irreducible polynomial of degree deg. If the integer f in binary representation is f = sum(a_i * 2**i, i=0,1,...,deg), a_i = 0,1, then the corresponding polynomial f(X) in GF(2)[X] is f(X) = sum(a_i * X**i, i=0,1,...,deg). The field GF(2**deg) is constructed as GF(2)[X]/(f(X)). Example: ==> gf2n_init(53). -: 9_00719_92547_41063 ==> write(_:base(2)). 100000_00000000_00000000_00000000_00000000_00000000_01000111 -: 1 In this case the irreducible polynomial serving to construct the field GF(2**53) is f(X) = X**53 + X**6 + X**2 + X + 1. (*----------------------------------------------------------*) gf2n_fieldpol(): integer; Returns the irreducible polynomial defining the field GF(2**n) which is active at present. The polynomial is represented by an integer; see description of the function gf2n_init(). (*----------------------------------------------------------*) gf2n_degree(): integer; Returns the degree of the field GF(2**n) which is currently active. (*----------------------------------------------------------*) gf2nint(x: integer): gf2nint; integer(x: gf2nint): integer; Conversion from data type integer to gf2nint and vice versa. (*----------------------------------------------------------*) max_gf2nsize(): integer; Returns the maximal degree of a field GF(2**n) supported by the present version of ARIBAS. (*----------------------------------------------------------*) gf2n_trace(z: gf2nint): integer; Returns the trace 0 or 1 of an element z in GF(2**n). The trace of z is 0 if and only if the quadratic equation x**2 + x = z has a solution x in GF(2**n). (*----------------------------------------------------------------*) a2) Polynomials over GF(2) ========================== gf2X_mult gf2X_square gf2X_divide gf2X_div gf2X_mod gf2X_gcd gf2X_modpower gf2X_primetest ARIBAS has several builtin functions dealing with polynomials over the field GF(2) with two elements 0,1. In these functions, polynomials are represented by integers. The correspondence is defined as follows: The integer f = sum( ai * 2**i, 0 <= i <= n), ai = 0,1 represents the polynomial F(X) = sum( ai * X**i, 0 <= i <= n). For example, ==> f := 2**7 + 2**6 + 1. -: 193 represents the polynomial F(X) = X**7 + X**6 + 1. By the way, this polynomial is irreducible, as can be seen by ==> gf2X_primetest(f). -: true Polynomials over GF(2) can be added using the function bit_xor. ==> g := 2**6 + 2**4 + 1. -: 81 ==> h := bit_xor(f,g). -: 144 ==> write(h:base(2)). 10010000 -: 1 This h represents the polynomial X**7 + X**4. (*----------------------------------------------------------------*) gf2X_mult(f,g: integer): integer; Multiplies two polynomials over GF(2) given by the integers f, g. Example: ==> f := 2**7 + 2**6 + 1. -: 193 ==> g := 2**6 + 2**4 + 1. -: 81 ==> h := gf2X_mult(f,g). -: 15505 ==> write(h:base(2)). 111100_10010001 -: 1 The product h represents the polynomial H(X) = X**13 + X**12 + X**11 + X**10 + X**7 + X**4 + 1. (*----------------------------------------------------------------*) gf2X_square(f: integer): integer; gf2X_square(f) is functionally equivalent to gf2X_mult(f,f), but runs faster. (*----------------------------------------------------------------*) gf2X_divide(f,g: integer): array[2]; gf2X_div(f,g: integer): integer; gf2X_mod(f,g: integer): integer; If f and g are two polynomials over GF(2) and g /= 0, then there exist polynomials q and r with deg(r) < deg(g) such that f = q*g + r The function gf2X_divide(f,g) returns the pair (q,r), the function gf2X_div(f,g) returns the quotient q) and gf2X_mod(f,g) returns the remainder r. (*----------------------------------------------------------------*) gf2X_gcd(f,g: integer): integer; Returns the greatest common divisor of the polynomials f,g. Example: ==> f := 2**10 + 1. -: 1025 ==> g := 2**4 + 1. -: 17 ==> gf2X_gcd(f,g). -: 5 This shows that the gcd of the polynomials X**10 + 1 and X**4 + 1 is X**2 + 1. (*----------------------------------------------------------------*) gf2X_modpower(g,n,F: integer): integer; Calculates the n-th power of the polynomial g modulo the polynomial F. ==> g := 2**5 + 2**4 + 1. -: 49 ==> F := 2**10 + 1. -: 1025 ==> h := gf2X_modpower(g,12345,F). -: 67 ==> write(h:base(2)). 1000011 -: 1 Thus (X**5 + X**4 + 1)**12345 = (X**6 + X + 1) mod (X**10 + 1). (*----------------------------------------------------------------*) gf2X_primetest(f: integer): boolean; Tests whether the polynomial f is irreducible. Example. ==> f0 := 2**100 + 1. -: 1_26765_06002_28229_40149_67032_05377 ==> for k := 1 to 99 do f := f0 + 2**k; if gf2X_primetest(f) then writeln(k); break; end; end; f. 15 -: 1_26765_06002_28229_40149_67032_38145 This shows that the polynomial X**100 + X**15 + 1 is irreducible over GF(2). (*----------------------------------------------------------------*) b) Functions for real arithmetic and analysis ============================================= floor trunc frac round set_floatprec get_floatprec decode_float float sqrt exp log sin cos tan arctan arctan2 arcsin arccos pi (*----------------------------------------------------------------*) floor(x: real): integer; Returns the greatest integer n <= x. Examples: ==> floor(pi). -: 3 ==> floor(-pi). -: -4 (*----------------------------------------------------------------*) trunc(x: real): integer; If x >= 0, equivalent to floor(x). For x < 0, trunc is defined by trunc(x) = -trunc(-x) Examples: ==> trunc(pi). -: 3 ==> trunc(-pi). -: -3 (*----------------------------------------------------------------*) frac(x: real): real; Defined by the equation x = trunc(x) + frac(x) Examples: ==> frac(1.23). -: 0.230000000 ==> frac(-1.23). -: -0.230000000 (*----------------------------------------------------------------*) round(x: real): integer; Rounds x to the next integer n. If x has exactly the distance 1/2 from two integers, rounds to the even integer. Examples: ==> round(pi). -: 3 ==> round(3.5). -: 4 ==> round(2.5). -: 2 (*----------------------------------------------------------------*) set_floatprec(bb: integer): integer; set_floatprec(Floattype): integer; This function serves to set the precision (in bits) which is used for subsequent calculations with reals. By default, a precision of 32 bits is used (corresponding to 9-10 decimal places), but it can be set to several higher values up to an implementation dependent limit, which can be determined by the function max_floatprec(). The argument of set_floatprec is either an integer bb, indicating the number of bits (which is rounded to the next higher available precision, if necessary) or a symbol Floattype, for which the following choice is available: single_float: 32 bits double_float: 64 bits long_float: 128 bits The function returns the new float precision. Example: ==> set_floatprec(double_float). -: 64 ==> sqrt(2). -: 1.41421356237309505 ==> set_floatprec(200). -: 256 ==> 2**0.5. -: 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37694_80731_76679_ 73799_07324_7846 (*----------------------------------------------------------------*) get_floatprec(): integer; get_floatprec(x: real): integer; In the first form (without arguments), the function returns the current float precision (in bits, a number between 32 and max_floatprec(), which is implementation dependent, typically 1024 or 4096). The default float precision of ARIBAS is 32 bits. If the argument is a real number x, the precision of x is returned. Examples: ==> set_floatprec(50). -: 64 ==> get_floatprec(1/3). -: 64 ==> get_floatprec(pi). -: 4096 (*----------------------------------------------------------------*) max_floatprec(): integer; This function returns the maximum floating point precision (in bits) which is available in the current implementation of ARIBAS. Example: ==> max_floatprec(). -: 4096 The actually used floating point precision can be retrieved by the function get_floatprec; it can be changed using the function set_floatprec. (*----------------------------------------------------------------*) decode_float(x: real): array[2] of integer; For a real number x, the function decode_float(x) returns a pair (mant, expo) of integers, reflecting the internal representation of x. The following equation holds: x = mant * 2**expo Example: ==> set_printbase(16). -: 0x10 ==> decode_float(-1/3). -: (-0xAAAA_AAAA, -0x21) (*----------------------------------------------------------------*) float(x: integer [; Floattype]): real; float(x: real [; Floattype]): real; Floattype must be one of the symbols single_float, double_float, long_float, or an integer bb indicating the desired float precision. If this argument is not given, the current float precision is assumed. The function transforms the number x to data type real with float precision Floattype. Examples: Suppose that the current float precision is single_float. ==> float(5). -: 5.00000000 ==> x := 1/10; y := float(x,long_float). -: 0.100000000 ==> set_printbase(16). -: 0x10 ==> decode_float(x). -: (0xCCCCCCCC, -0x23) ==> decode_float(y). -: (0xCCCC_CCCC_0000_0000_0000_0000_0000_0000, -0x83) (*----------------------------------------------------------------*) pi The constant pi is stored internally with the maximal available precision (which can be determined by the function max_floatprec()), although this is not shown in the printed representation, if the currently used precision is smaller. ==> pi. -: 3.14159265 ==> get_floatprec(pi). -: 4096 Note however, that calculations are always done with the current float precision. For example, if the current float precision is single_float = 32 bits, ==> x := 1*pi. -: 3.14159265 ==> get_floatprec(x). -: 32 ==> x = pi. -: false (*----------------------------------------------------------------*) sqrt(x: real): real; exp(x: real): real; log(x: real): real; sin(x: real): real; cos(x: real): real; tan(x: real): real; arctan(x: real): real; arcsin(x: real): real; arccos(x: real): real; The functions sqrt (square root), exp, log (natural logarithm), sin, cos, tan, arctan, arcsin, arccos all expect one real argument and return a real. If the argument is an integer, it is automatically transformed to a real. Example: ==> log(2). -: 0.693147180 ==> set_floatprec(100). -: 128 ==> log(2). -: 0.69314_71805_59945_30941_72321_21458_17656_81 ==> exp(_). -: 2.00000_00000_00000_00000_00000_00000_00000_0 (*----------------------------------------------------------------*) arctan2(y,x: real): real; The two numbers x,y may not be simultaneously 0. The function returns an angle phi with -pi < phi <= pi, satisfying x = r * cos(phi); y = r * sin(phi); where r = sqrt(x*x + y*y). If x > 0, then arctan2(y,x) = arctan(y/x). Example: ==> arctan2(1,0). -: 1.57079633 (*----------------------------------------------------------------*) c) Random ========= random random_seed (*----------------------------------------------------------*) random(n: integer): integer; Returns an integer pseudo random number z with 0 <= z < x. (*----------------------------------------------------------*) random(x: real): real; Returns a real pseudo random number z with 0 <= z < x. (*----------------------------------------------------------*) random_seed([s: integer]): integer; random_seed without an argument returns the present state of the random generator (which is an integer z with 2**48 <= z < 2**49). With an integer argument s, the state of the random generator is set to a value z such that z = s mod 2**48 and 2**48 <= z < 2**49. In this way one can generate reproducible values of the random function (for test purposes). (*----------------------------------------------------------*) d) Characters, strings ====================== chr ord length concat toupper tolower string_split substr_index string_scan itoa ftoa float_ecvt atoi atof (*----------------------------------------------------------*) chr(n: integer): char; ord(ch: char): integer; The function chr generates the character with ASCII-Code n (0 <= n < 256), ord is the inverse function of chr. Examples: ==> chr(63). -: '?' ==> ord('?'). -: 63 (*----------------------------------------------------------*) length(s: string): integer; Returns the length of the string s. (The function length can also be applied to byte_strings, arrays, stacks and files.) (*----------------------------------------------------------*) concat(arg0, arg1, ... , argn): string; The function concat expects one or more arguments which must be strings or characters. The result is a string which is the concatenation of all arguments. Example: ==> concat("string",'_',"split"). -: "string_split" (*----------------------------------------------------------*) toupper(str: string): string; toupper(ch: character): character; Transforms a string resp. a character to upper case. Only characters between 'a' and 'z' are affected. All others remain untouched. Example: ==> toupper("Zapp-up!"). -: "ZAPP-UP!" (*----------------------------------------------------------*) tolower(str: string): string; tolower(ch: character): character; Transforms a string resp. a character to lower case. Only characters between 'A' and 'Z' are affected. All others remain untouched. (*----------------------------------------------------------*) string_split(str: string [; sep: string]): array of string; Splits the string str into one or more parts and returns a vector whose components are these parts. The splitting uses as separators the characters contained in the string sep. If the argument sep is not supplied, SPACE, TAB, CR and NEWLINE are used by default. Examples; ==> string_split("abc def"). -: ("abc", "def") ==> string_split("abc def;xxx=yyy",";= "). -: ("abc", "def", "xxx", "yyy") (*----------------------------------------------------------*) substr_index(str, str1: string): integer; Searches for an occurrence of str1 as a substring of str and returns the position (the count begins with 0). If str1 does not occur as a substring of str, -1 is returned. Examples: ==> substr_index("string_split","split"). -: 7 ==> substr_index("string_split","Split"). -: -1 Instead of strings, str or str1 may also be byte_strings. (*----------------------------------------------------------*) string_scan(str, set: string [; mode: boolean]): integer; When mode=true (default), searches for the first occurrence of a character from the string set in the string str and returns its position. If no character from set occurs in str, -1 is returned. Example: ==> str := "vec := (1,2,3)". -: "vec := (1,2,3)" ==> string_scan(str,"+-()"). -: 7 ==> string_scan(str,"+-[]"). -: -1 If the string set consists of a single character, then string_scan(str,set) is equivalent to substr_index(str,set). When mode=false, searches for the first occurence in str of a character which is not in the string set and returns its position. If no such character is found, -1 is returned. Example: ==> digits := "0123456789". -: "0123456789" ==> string_scan("123 + 456",digits,false). -: 3 ==> string_scan("123456",digits,false). -: -1 Instead of strings, str or set may also be byte_strings. (*----------------------------------------------------------*) itoa(x: integer [; base: integer]): string; The integer x is converted to a string, giving the textual representation of this integer. The second optional argument is the base to be used, which may have one of the values 2,8,10,16. By default, base 10 is used. Example: ==> itoa(1234). -: "1234" ==> itoa(1234,16). -: "4D2" (*----------------------------------------------------------*) ftoa(x: real): string; The real number x is converted to a string. Examples: ==> ftoa(1/239). -: "0.00418410042" ==> ftoa(pi*10**100). -: "3.14159265E100" (*----------------------------------------------------------*) atoi(s: string [; var len: integer]): integer; A string s, representing an integer, is transformed to this integer. The function may be called with an optional second variable argument len. The function stores in len an integer, which in general is the length of the string s. If len < length(s), then only the substring containing the first len characters of s is an admissible representation of an integer. In particular len=0 indicates a non-admissible string. Examples: ==> atoi("1234"). -: 1234 ==> atoi("0x1234"). -: 4660 ==> atoi("-1234 5678",len). -: -1234 ==> len. -: 5 ==> atoi("_1234",len). -: 0 ==> len. -: 0 (*----------------------------------------------------------*) atof(s: string [; var len: integer]): real; A string s, representing a real number, is transformed to this real. A second optional variable argument len has a meaning analogous to the function atoi. (*----------------------------------------------------------*) float_ecvt(x: real; ndig: integer; var decpos, sign: integer): string; The real x is transformed to a string of length ndig. The string contains only digits. The position of the decimal point is returned in the variable paramenter decpos (decpos < 0 means that the decimal point is to the left of the beginning of the string). The sign of x is returned in the variable parameter sign (sign = 0 means x >= 0, sign /= 0 means x < 0). float_ecvt is analogous to the UNIX C-function ecvt. Example: ==> float_ecvt(pi,10,decpos,sign). -: "3141592654" ==> decpos. -: 1 ==> sign. -: 0 (*----------------------------------------------------------*) e) Byte_strings =============== length byte_string string cardinal integer (*----------------------------------------------------------*) length(b: byte_string): integer; Returns the length of the byte_string b. (*----------------------------------------------------------*) cardinal(b: byte_string): integer; Transforms a byte_string into a non-negative integer. The components of the byte_string are considered as the digits of an integer with respect to base 256, where the leftmost byte of the byte_string corresponds to the least significant digit. Therefore the function returns the integer sum(b[i] * 256**i: 0 <= i < length(b)). Example: ==> cardinal($000A). -: 2560 (*----------------------------------------------------------*) integer(b: byte_string): integer; Transforms a byte_string into an integer. The components of the byte_string are considered as the digits of an integer with respect to base 256 in two's complement representation. If len := length(b) and the most significant bit of b[len-1] is not set, then integer(b) = cardinal(b). But if the most significant bit of b[len-1] is set, then integer(b) = cardinal(b) - 256**len. Examples: ==> integer($5470). -: 28756 ==> integer($5480). -: -32684 (*----------------------------------------------------------*) byte_string(x: integer): byte_string; byte_string(x: integer; len: integer): byte_string; byte_string(x) transforms an integer x into a byte_string of length equal to byte_length(x). It is the inverse function of integer(bb: byte_string): integer; If a second argument len is given and len < byte_length(x), then the byte_string is truncated and only the len least significant bytes are retained. If len > byte_length(x), bytes of value 0 (if x >= 0) resp. 0xFF (if x < 0) are added, so that the total length of the resulting byte_string equals len. Examples: ==> set_printbase(16). -: 0x10 ==> x := 65111. -: 0xFE57 ==> byte_string(x). -: $57FE ==> byte_string(-x). -: $A901 ==> byte_string(x,4). -: $57FE_0000 ==> byte_string(-x,4). -: $A901_FFFF ==> byte_string(x,1). -: $57 ==> 17**17. -: 0x2C_D843_CB47_6437_0911 ==> byte_string(_). -: $1109_3764_47CB_43D8_2C (*----------------------------------------------------------*) byte_string(s: string): byte_string; Transforms an ordinary (text) string into a byte_string. The components of the resulting byte_string are the ASCII codes of the characters of s. Example: ==> byte_string("string"). -: $7374_7269_6E67 (*----------------------------------------------------------*) string(b: byte_string): string; Transforms a byte_string into a text string; inverse function of byte_string. Be careful if some components of the byte_string b are codes of non-printable control characters. (*----------------------------------------------------------*) Bit operations for byte_strings ------------------------------- mem_btest mem_bset mem_bclear mem_not mem_and mem_or mem_xor mem_shift mem_bitswap mem_byteswap All these bit operations, with the exception of mem_btest, change its first variable argument, which is a byte_string, and return this modified byte_string. The return value is only interesting when the functions are used interactively. (*----------------------------------------------------------------*) mem_btest(var b: byte_string; n: integer): integer; Returns the value 1 or 0 of the bit at position n in the byte_string b (position is zero based). (*----------------------------------------------------------------*) mem_bset(var b: byte_string; n: integer): byte_string; Sets the bit at position n in the byte_string b to 1 and returns the modified byte_string. (*----------------------------------------------------------------*) mem_bclear(var b: byte_string; n: integer): byte_string; Clears the bit at position n in the byte_string b (i.e. sets it to 0) and returns the modified byte_string. (*----------------------------------------------------------------*) mem_not(var b: byte_string): byte_string; Inverts all bits in the byte_string b and returns the modified byte_string. (*----------------------------------------------------------------*) mem_and(var b1,b2: byte_string): byte_string; mem_or(var b1,b2: byte_string): byte_string; mem_xor(var b1,b2: byte_string): byte_string; The first byte_string argument b1 is replaced by the bitwise and (resp. or, xor) of b1 and b2. The modified byte_string b1 is returned. Note that although the second argument b2 is not modified, it must be a variable argument (no byte_string literals are allowed). The reason for this rule is higher efficiency. (*----------------------------------------------------------------*) mem_shift(var b: byte_string; n: integer): byte_string; Performs a bit shift by abs(n) binary digits. if n > 0, the direction is from least-significant to most-significant, for n < 0, the shift is in the opposite direction. abs(n) bits are lost. They are replaced by 0's. Example: ==> bb := $ABCD; mem_shift(bb,4). -: $B0DA ==> mem_shift(bb,4). -: $00AB (*----------------------------------------------------------------*) mem_bitswap(var b: byte_string): byte_string; Within each byte of b, the 8 bits are swapped from most significant <--> least significant, that is, sum{b_k*2**k, 0 <= k < 8} is replaced by sum{b_k*2**(7-k), 0 <= k < 8}. The modified byte_string is returned. Example: ==> bb := $0102_1e2f. -: $0102_1E2F ==> mem_bitswap(bb). -: $8040_78F4 (*----------------------------------------------------------------*) mem_byteswap(var b: byte_string; wordlen: integer): byte_string; The byte_string is subdivided in groups of wordlen bytes each. Within each group, the bytes are swapped from most significant <--> least significant. The modified byte_string is returned. Example: ==> bb := $AABBCCDDEE. -: $AABB_CCDD_EE ==> mem_byteswap(bb,2). -: $BBAA_DDCC_EE ==> mem_byteswap(bb,5). -: $EECC_DDAA_BB The functions mem_byteswap and mem_bitswap are useful for transforming bitmaps. (*----------------------------------------------------------------*) f) Arrays, records ================== length sum product sort binsearch alloc realloc max_arraysize new nil (*----------------------------------------------------------------*) length(vec: array): integer; Returns the length of the array vec. (*----------------------------------------------------------------*) sum(vec: array of integer): integer; sum(vec: array of real): real; product(vec: array of integer): integer; product(vec: array of real): real; Returns the sum resp. the product of all components of vec. (*----------------------------------------------------------*) sort(var vec: array of integer): array of integer; sort(var vec: array of real): array of real; sort(var vec: array of string): array of string; The array vec, which is passed to the function sort as a variable argument, is sorted in non-decreasing order (for strings, the lexicographic order with respect to the ASCII-codes of characters is used). The sorted array is returned. sort(var vec: array of Type; compfun: function): array of Type; The function sort may be given as a second optional argument a comparison function compfun(x,y: Type): integer; which must be a function of two arguments of the same data type as the components of the array. The relation defined by compfun(x,y) <= 0 must be transitive. Then vec is sorted in non-decreasing order, where x <= y is defined by compfun(x,y) <= 0. Example: Consider an array of pairs of integers. We define the following comparison function ==> function compare2(x,y: array[2]): integer; begin return x[1] - y[1]; end. -: compare2 ==> vec := ((1,7), (2,3), (3,4), (4,-1), (5,2)); sort(vec,compare2). -: ((4, -1), (5, 2), (2, 3), (3, 4), (1, 7)) (*----------------------------------------------------------------*) binsearch(ele: ; var vec: array of [; compfun: function]): integer; The array vec must be a sorted array of elements of type . The function searches in this array for an occurrence of the element ele and returns its position (zero-based). If ele is not found, -1 is returned. The third argument of binsearch is a comparison function compfun(x,y: ): integer; which must be a function of two arguments of the same data type as the components of the array (see function sort). If vec is an array of integers, characters or strings, then the comparison function may be omitted. In this case the natural order (numerical resp. alphabetical) is assumed. (*----------------------------------------------------------------*) alloc(Arraytype, Len [,Ele]): Arraytype; Arraytype must be one of the symbols array, string, byte_string. The function generates an array (resp. a string, a byte_string) of length Len, where all components are equal to Ele. If the argument Ele is not given, a default element is used. This default element is 0 for arrays, the space character ' ' for strings, and the zero byte for byte_strings. Examples: ==> alloc(array,10). -: (0, 0, 0, 0, 0, 0, 0, 0, 0, 0) ==> alloc(string,5,'A'). -: "AAAAA" ==> alloc(byte_string,5,127). -: $7F7F_7F7F_7F (*----------------------------------------------------------------*) realloc(var vec: ; len: integer [; ele]): The variable argument vec must be an array, a string or a byte_string. If the integer len is bigger than the length of vec, the function increases the length of vec to len by appending components of value ele at the end. If ele is not given, default values are used. The new array (resp. string}, byte_string) is returned and also placed in the variable vec. If len is equal to the length of vec, then vec remains unchanged. If len is smaller than the length of vec, then vec is truncated to this smaller length. Examples: ==> vec := (17,4,31). -: (17, 4, 31) ==> realloc(vec,5,53). -: (17, 4, 31, 53, 53) ==> bb := $AABB. -: $AABB ==> realloc(bb,10). -: $AABB_0000_0000_0000_0000 ==> s := "abcde". -: "abcde" ==> realloc(s,3). -: "abc" (*----------------------------------------------------------*) max_arraysize(): integer; In the present version of ARIBAS, lengths of arrays cannot be very large. The function max_arraysize returns the maximal admissible length. Typically, under UNIX, this value is about 64000, under MSDOS about 12000 or 16000. The maximal admissible length for strings and byte_strings is min(4*max_arraysize(), 2**16-1). (*----------------------------------------------------------*) new(var ptr: pointer to RecType): Rectype; If ptr is a variable of type pointer to a certain record type, then new(ptr) creates a new record of that type and makes ptr point to this record. For example, after the variable declaration var ptr: pointer to record x,y,w,h: integer; end; end; ptr has the value nil. Calling ==> new(ptr). -: &(0, 0, 0, 0) produces a record with four integer fields which can be accessed by ptr^.x, ptr^.y, ptr^.w and ptr^.h. For example ==> ptr^.x := ptr^.y := 10; ptr^.w := 512; ptr^.h := 360. -: 360 ==> ptr^. -: &(10, 10, 512, 360) (*----------------------------------------------------------*) g) Stacks ========= length stack_push stack_arraypush stack_pop stack_top stack_reset stack_empty stack2array stack2string (*-----------------------------------------------------------------*) There are no stack literals. One can generate stacks by variable declarations. For example, the following top level declaration var st: stack; end. generates an empty stack. Afterwards, one can put elements onto the stack using the function stack_push. (*-----------------------------------------------------------------*) length(st: stack): integer; Returns the length of the stack st, i.e. the number of elements (of arbitrary data type) which lie on the stack. (*-----------------------------------------------------------------*) stack_push(st: stack; ele: Type): Type; Puts an element ele (of arbitrary data type Type) on top of the stack st. The length of the stack is increased by 1. The return value of the function is ele. (*-----------------------------------------------------------------*) stack_arraypush(st: stack; vec: array of [; direction: integer]): integer; Pushes the components of the array vec onto the stack st. If the argument direction is positive or omitted, the order is from beginning to the end of vec. If direction is negative, the pushing occurs in reverse order. Return value is the number of elements pushed on st (= the length of vec). Examples: ==> var st: stack; end. -: var ==> vec := (1,2,3,4,5). -: (1, 2, 3, 4, 5) ==> stack_arraypush(st,vec,-1). -: 5 ==> vec1 := stack2array(st). -: (5, 4, 3, 2, 1) (*-----------------------------------------------------------------*) stack_pop(st: stack): Type; The stack st must be non-empty. The function removes the top element of st and returns it. The length of the stack is decreased by 1. (*-----------------------------------------------------------------*) stack_top(st: stack): Type; Returns the top element of the stack st; the stack itself is not altered. (*-----------------------------------------------------------------*) stack_reset(st: stack): integer; Removes all elements from the stack st. There remains an empty stack. The function returns 0. (*-----------------------------------------------------------------*) stack_empty(st: stack): boolean; Tests if the stack st is empty. (*-----------------------------------------------------------------*) stack2array(st: stack): array of Type; Returns an array of length equal to length(st) whose components are the elements lying on the stack. The element at the bottom of the stack becomes the component of index 0. After execution of this function, the stack st is empty. It is in the responsibility of the programmer to ensure that all element have the correct data type. (*-----------------------------------------------------------------*) stack2string(st: stack): string; The elements on the stack st, which are strings or characters, are concatenated to a string. This string is returned. Elements of other data types on the stack are ignored. After execution of this function, the stack st is empty. Example: ==> var st: stack; end. -: var ==> stack_push(st,"stack"). -: "stack" ==> stack_push(st,pi). -: 3.14159265 ==> stack_push(st,'_'). -: '_' ==> stack_push(st,"push"). -: "push" ==> stack2string(st). -: "stack_push" (*-----------------------------------------------------------------*) h) In/Out ========= write writeln flush readln load open_read open_write open_append rewind close set_filepos get_filepos length read_byte read_block write_byte write_block Predifined files: stdin stdout stderr (*--------------------------------------------------------------------*) open_write(var f: file; fnam: string): boolean; Opens a file with name fnam for write operations and sets the file variable f. (This file variable is needed for the write operations.) If a file with name fnam does not exist, it is created. Return value: true if the file has been succesfully opened, and false, if an error occurs. CAUTION: If a file with name fnam exists already, its previous content is overwritten and will be lost. (*--------------------------------------------------------------------*) open_append(var f: file; fnam: string): boolean; Opens a file with name fnam for write operations and sets the file variable f. (This file variable is needed for the write operations.) If a file with name fname does not exist, it is created. If the file exists already, the previous content is preserved and the new write operations are at the end of the file. Return value: true if the file has been succesfully opened, and false, if an error occurs. (*--------------------------------------------------------------------*) open_read(var f: file; fnam: string): boolean; Opens an existing file with name fnam for sequential reading. Return value: true if the file has been succesfully opened, and false, if an error occurs. (*--------------------------------------------------------------------*) rewind(var f: file): boolean; If f is a file which has been opened for reading and from which some data have already been read, rewind(f) resets the file position for the the next read operation to the beginning of the file. Return value: true if successful, else false. (*--------------------------------------------------------------------*) close(f: file): boolean; Closes a file f which has been opened before. (*--------------------------------------------------------------------*) length(f: file): integer; f must be a file opened for reading. Then the function returns the length of the file in bytes. (*--------------------------------------------------------------------*) Read and write operations on text files readln write writeln (*--------------------------------------------------------------------*) readln([f: file;] var arg1,...,argn): integer; Reads a line from file f, which must have been opened for reading. (If the file argument is not supplied, stdin is assumed, i.e. readln reads from the terminal.) The arguments arg1,...,argn must be of type integer, real, char or string. (A string variable always consumes all characters until the end of line.) The return value of readln is the number of successfully read items. If the end of file is already reached before the call of readln, -1 is returned. For example, assume that x is an integer variable, c1, c2 are character variables and s is a string variable. If the current line in the file f is 1234 56 ab (where the line ends immediately after the character b), then readln(f,c1,x,c2,s) will return 4 and the variables will contain the following values: c1 = '1', x = 234, c2 = ' ', s = "56 ab". If the same line is read with readln(f,s,x,c1,c2), then the return value is 1, the variable s contains the string "1234 56 ab", and x, c1, c2 are undefined. If an integer extends over more than one line, as in 3_14159_26535_89793_23846_26433_83279_50288_41971_69399_37510_58209_74944_ 59230_78164_06286_20899_86280_34825_34211_70679 where the continuation of the integer to the next line is marked by an underscore _, then this integer may be read by readln(f,x). While reading an integer, readln does not stop at the end of a line if the last character in the line is an underscore (no space or tab characters are allowed after the underscore). readln(f) without further arguments simply returns 0 and advances the file position to the beginning of the next line. (*--------------------------------------------------------------------*) write([f: file;] arg1,...,argn): integer; writeln([f: file;] arg1,...,argn): integer; Writes the arguments arg1,...,argn (which may have any data type) into a text file f, which must have been opened for writing. The function writeln adds a linefeed to the output. (If the file argument is not supplied, stdout is assumed, i.e. the functions write to the terminal.) Return value is the number of written arguments or -1 in case of error. (*--------------------------------------------------------------------*) FORMAT OPTIONS for the functions write and writeln -------------------------------------------------- As in Pascal, arguments of the functions write or writeln of certain data types can be supplemented by format specifications. In ARIBAS there are even more format options than in Pascal. The format specifications, which we will describe in the following, are separated from the argument by a colon. a) Width specification ---------------------- If x is an integer, character oder string expression, then an argument of the form x: wd determines the width of the output. wd must be an integer expression. If the value of width is bigger than the length of the string representation of x, then by inserting an appropiate number of space characters before x, the total width of the output is made equal to the value of wd. If the value of wd is negative and abs(wd) is bigger than the length of the string representation of x, then the necessary space characters are inserted after x. If abs(wd) is smaller or equal to the length of x, the format option is ignored. The same happens if abs(wd) is bigger than the line length. Example: ==> writeln("###",123:8,'#',"abc":-8,'X':-3,"###"); writeln("###",123:-8,'#',"abc":8,'X':3,"###"). ### 123#abc X ### ###123 # abc X### -: 6 b) Formatting reals ------------------- If x is a real, then an argument of the form x: wd causes the (right aligned) output of x in exponential notation with a total width equal to the value of wd, which must be at least 10. Example: ==> writeln("###",exp(1):15,"###"); writeln("###",-exp(10):15,"###"); writeln("###",exp(-10000):15,"###"). ### 2.718282E+0000### ###-2.202647E+0004### ### 1.135484E-4343### An argument of the form x: wd: dec causes the output of x in fixed point representation with a total width wd and dec digits after the decimal point. Example: ==> writeln("###",exp(1):15:5,"###"); writeln("###",exp(10):15:5,"###"). ### 2.71828### ### 22026.46579### -: 3 More elaborate format options for reals can be constructed using the function float_ecvt. c) Additional format options for integers ----------------------------------------- As extensions of the Pascal format options, ARIBAS admits further options which are also separated by a colon and which have the form base(n) group(n) digits(n) with an integer expression n. i) base(n) The format option base(n), where n may have one of the values 2, 8, 10 or 16 determines the base of the integer representation. Example: ==> x := 3**9; writeln(x:10, x:20:base(2), x:10:base(8), x:10:base(16)). 19683 1001100_11100011 46343 4CE3 -: 4 Note that write(x:base(n)) doesn't print the base prefix. If you want it to be written, you can achieve this as in the following example. ==> writeln("0y",3**9:base(2)). 0y1001100_11100011 -: 2 ii) group(n) The output of big integers in ARIBAS is structured by underscores. By default, ARIBAS uses for integers >= 2**32 an underscore after every 5 digits. This behavior can be customized by the group(n) option. Here n may be 0 or an integer >= 2. With the option group(0) no underscores are written; with the option group(n), n>=2, the output is subdivided in groups of n digits separated by underscores. Example: ==> x := 3**100; writeln(x); writeln(x: group(0)); writeln(x: group(10)). 515_37752_07320_11331_03646_11297_65621_27270_21075_22001 515377520732011331036461129765621272702107522001 51537752_0732011331_0364611297_6562127270_2107522001 -: 1 The group(n) option can also be applied to byte_strings. Here n must be even. Example: ==> bb := byte_string(17**37); for n := 0 to 10 by 2 do writeln(bb:group(n)); end. 513C759F43245912A19E1D5A0027B6B4F7C296 51_3C_75_9F_43_24_59_12_A1_9E_1D_5A_00_27_B6_B4_F7_C2_96 513C_759F_4324_5912_A19E_1D5A_0027_B6B4_F7C2_96 513C75_9F4324_5912A1_9E1D5A_0027B6_B4F7C2_96 513C759F_43245912_A19E1D5A_0027B6B4_F7C296 513C759F43_245912A19E_1D5A0027B6_B4F7C296 iii) digits(n) With the format option digits(n) one can force the output of leading zeroes. If n is bigger than the number of digits of an integer x with respect to a certain base, then leading zeroes are added such that the total number of digits equals n. If n is smaller than the number of digits of x, the format option is ignored. Example: ==> for x := 3 to 10 do writeln(x: 10: base(2): digits(4): group(2)); end. 00_11 01_00 01_01 01_10 01_11 10_00 10_01 10_10 The format options base, digits, group may appear in arbitrary order. (*--------------------------------------------------------------------*) flush([f: file]); If f is an output file (default f = stdout) to which write operations have been performed, but some of the data are still being held in a buffer, then flush writes all data actually to the file. (*--------------------------------------------------------------------*) load(fnam: string): boolean; fnam must be the name of a text file with ARIBAS source code, the extension .ari may be omitted. Then load reads this file and executes all commands and function definitions in the file as if they had been input directly at the ARIBAS prompt. Typically, a loaded file contains definitions of functions. As they are read in, the names of the functions are printed to the terminal screen. If the file contains expressions to be evaluated, the result is printed to the screen. The return value of load is true, if the load operation was successful. In case of error, an error message is written, specifying a line number, where the error was detected (actually the error might be in some previous line). If the string fnam consists of several components separated by whitespace, then the first component is considered as the name of the file to load and the other components are treated as arguments which are collected as strings (together with the file name) in the vector ARGV. For example, suppose that a file abc1.ari with ARIBAS code exists in the current directory. Then ==> load("abc1 8765 olfac"). will load the file abc1.ari and the vector ARGV will have the following content: ==> ARGV. -: ("abc1", "8765", "olfac") This is as if you had started ARIBAS with command line arguments aribas abc1 8765 olfac (See Chap.10, COMMAND LINE ARGUMENTS.) load(fnam,0). With a second argument 0 the function load works in quiet mode, the messages to terminal are suppressed. (*--------------------------------------------------------------------*) BINARY FILES: In ARIBAS, files are text files by default. However, files can also be opened in binary mode for reading and writing using the functions open_write, open_read, open_append. In this case, a third argument, consisting of the keyword binary, must be given. Example: ==> open_read(f,"BIN.DAT",binary). This opens a file with name "BIN.DAT", which is supposed to exist, for reading in binary mode. For binary files there are the read operations read_byte and read_block and the write operations write_byte and write_block. The functions rewind and length may also be applied to binary files, which have been opened for reading. (*--------------------------------------------------------------------*) set_filepos(f: file; pos: integer): integer; f must be a binary file, opened for reading and pos must be an integer satisfying 0 <= pos < length(f). Then set_filepos sets the position for the next read operation at pos bytes from the beginning of the file. If pos is not in the admissible range, no action is taken. Return value is the file position after execution of set_filepos. (*--------------------------------------------------------------------*) get_filepos(f: file): integer; f must be a binary file, opened for reading. The function returns the current file position. (*--------------------------------------------------------------------*) read_byte(f: file): integer; Reads one byte at the current file position from a binary file opened for reading and increases the file position by 1. Return value is the read byte (an integer in the range 0 <= x < 256). If the file position is already end-of-file when read_byte is called, then -1 is returned and the file position remains unchanged. (*--------------------------------------------------------------------*) read_block(f: file; var block: byte_string; len: integer): integer; f must be a binary file opened for reading. The argument block must be a byte_string variable or a subarray of a byte_string with an actual length >= len. Then read_block reads len bytes from the file f (starting at the current file position) and stores them into the first len components of block. If the end-of-file is reached prematurely, the reading oeration is stopped and only the bytes read so far are stored in block. Return value of read_block is the number of actually read bytes. The file position is advanced by this value. (*--------------------------------------------------------------------*) write_byte(f: file; x: integer): integer: Writes one byte (given by an integer x in the range 0 <= x < 256) into a binary file f opened for writing (using open_write or open_append). Instead of an integer x one can use also a character. Return value in case of success is the written byte. In case of error, -1 is returned. (*--------------------------------------------------------------------*) write_block(f: file; var block: byte_string; len: integer): integer; f must be a binary file opened for writing. The argument block must be a byte_string variable or a subarray of a byte_string with an actual length >= len. Then write_block writes the first len bytes from block into the file f. Return value of write_block is the number of successfully written bytes. If no error occurs, this number equals len. (*-----------------------------------------------------------------*) i) System functions ==================== version memavail gc timer gmtime halt exit symbols make_unbound help transcript system getenv set_workdir get_workdir (*-----------------------------------------------------------------*) version(): integer; Writes the version number and the architecture, for which ARIBAS was compiled, to the terminal screen. Returns an integer, which is 100*(major version no) + (minor version no). Example: ==> version(). ARIBAS Version 1.01, Sep. 1996 (MS-DOS 386) -: 101 With the optional argument 0, the message to the screen is suppressed. Example: ==> version(0). -: 101 (*-----------------------------------------------------------------*) memavail(): integer; Writes some memory statistics to the screen and returns the free space (measured in KB) on the ARIBAS heap. Example: ==> memavail(). total number of garbage collections: 2 130044 Bytes reserved; 130044 Bytes active (97900 used, 32144 free) 10926 Bytes free for user defined symbols and symbol names -: 31 Since ARIBAS has a garbage collector using the half space method, the ARIBAS heap is subdivided into two equal parts (in this example 130044 bytes each). One part is active, memory requirements (for example for big integers) are satisfied from this part. In the above example 32144 bytes are still available. If the memory in the active part is exhausted, the garbage collector is called automatically. The total number of garbage collections since the beginning of the current ARIBAS session is also given. The names of user defined functions and variables are stored by ARIBAS in a symbol table. The space still available for this purpose is also reported. One can suppress all messages by calling memavail with the argument 0. ==> memavail(0). -: 31 (*-----------------------------------------------------------------*) gc(): integer; Forces a garbage collection and returns the new amount of memory (in KB) on the ARIBAS heap. The function outputs the same messages as the function memavail. A quiet version is gc(0). This is useful for example, if one wants to call some procedure only if a certain minimal amount of memory is available, as in the following code if gc(0) < 64 then writeln("not enough memory for procedure foo"); else foo(...); ... end; (*-----------------------------------------------------------------*) timer(): integer; Returns the number of milliseconds elapsed since a certain starting point dependend on the current computer session. (The precision is system dependent.) This can be used for example to measure the time needed to execute a certain function. Example: ==> t := timer(); x := isqrt(2*10**2000); timer() - t. -: 88 In the above example, which was done under LINUX on a computer with a 80486 processor, 33MHz, the square root of 2 was calculated with a precision of 1000 decimal places in 88 milliseconds. (*-----------------------------------------------------------------*) gmtime(): string; Returns Greenwich Mean Time as a string in the format "YYYY:MM:DD:hh:mm:ss" (year, month, day, hour, minutes, seconds). You can use the function string_split to retrieve the components of this string and use it to write your own custumized time function. Example: ==> gmtime(). -: "2003:06:09:08:26:20" ==> tt := string_split(_,":"). -: ("2003", "06", "09", "08", "26", "20") ==> t0 := alloc(array,6); for k := 0 to 5 do t0[k] := atoi(tt[k]); end; t0. -: (2003, 6, 9, 8, 26, 20) gmtime(0): integer; If gmtime is called with the argument 0, then it returns the number of seconds passed since Jan. 1, 2000, 0:00 h GMT. Example: ==> gmtime(0). -: 108462687 (*-----------------------------------------------------------------*) symbols(aribas). Returns a list of ARIBAS keywords and builtin functions. The argument aribas has to be given as it stands (without quotes). symbols(user). Returns a list of currently user defined variables and functions. (*-----------------------------------------------------------------*) make_unbound(Sym): boolean; The symbol Sym denoting a user defined variable, constant or function can be made unbound. Builtin functions cannot be made unbound. Returns true if the removal of binding was successful. Example: ==> vec := (2,3,4). -: (2, 3, 4) ==> vec. -: (2, 3, 4) ==> make_unbound(vec). -: true ==> vec. eval: unbound symbol: vec -: error make_unbound is useful if one wants to recover memory used for variables (holding e.g. big integers or long arrays) which are no longer needed. The argument to make_unbound may also be the symbol user: make_unbound(user): boolean; This unbinds all user defined variables, constants and functions. Example: ==> symbols(user). -: (ecN_add, ecN_dup, ecN_mult, ec_bigprimevar, ec_fact0, ec_factbpv, ec_factorize, ecfactor, factor0, factorlist, factors, modpemult, ppexpo, primelist, x, y) ==> make_unbound(user). -: true ==> symbols(user). -: () (*-----------------------------------------------------------------*) help(Topic) Gives a short online help on Topic. For Topic one can use most symbols of the list returned by the command symbols(aribas). For example, ==> help(factor16). gives a short description of the builtin function factor16. The help function depends on the file aribas.hlp, which contains the help texts. Under MS-DOS, this file must lie in the same directory as aribas.exe, under UNIX it must be in the search path. (*-----------------------------------------------------------------*) transcript([fnam: string]): boolean; Opens a log file with name fnam. The extension .log is appended automatically to fnam, if fnam has no extension. If no argument is given to transcript, "aribas.log" is used by default. For example, ==> transcript("a1"). -: true opens a file a1.log (if it exists already, its previous content is lost). The effect of transcript is that all subsequent interaction between the user and ARIBAS is transcribed to the log file until the log file is closed again with the command ==> transcript(0). The end of an ARIBAS session closes the log file automatically. (*-----------------------------------------------------------------*) system(command: string): integer; The string command is handed to the command interpreter (resp. shell) of the system for execution. Return value is an error code or 0. For example, under MS-DOS, ==> system("dir"). generates a listing of the current directory. Under UNIX, you can use ==> system("ls -l"). for the same purpose. (*-----------------------------------------------------------------*) getenv(name: string): string; Returns the value of the environment variable name or the empty string, if this variable is not defined. Example: Under UNIX, ==> getenv("HOME"). returns the name of the home directory of the current user. (*-----------------------------------------------------------------*) get_workdir(): string; Retrieves the current working directory. (*-----------------------------------------------------------------*) set_workdir(path: string): string; Sets the current working directory to the one given by path. This can be either an absolute or a relative path. Return value is the new path. If the path does not exist, or ARIBAS is unable to open it, then the old working directory remains unchanged and the empty string is returned. Example: ==> set_workdir("D:\aribas\work"). -: "D:\aribas\work" (This example supposes that the directory "D:\aribas\work" exists.) (*-----------------------------------------------------------------*) halt([retcode: integer]): integer; A call to halt causes an immediate stop of the current function and a return to top level (even if halt occurs in a deeply nested function call). The return value is the optional argument retcode which must be a 16-bit integer (default value 0). The function halt is mainly used to recover from serious errors. Note: In contrast to exit, halt does not stop ARIBAS, but returns to the ARIBAS prompt. (*-----------------------------------------------------------------*) exit The command exit stops ARIBAS and returns to the shell or command interpreter from where ARIBAS was called. (*-----------------------------------------------------------------*) 9) USER DEFINED FUNCTIONS ========================= function procedure external const var begin end return (*--------------------------------------------------------------------*) In ARIBAS, all functions are defined at the same level (as in C). Nested function definitions (as in Pascal or Modula-2) are not allowed. Within function definitions one may refer to other functions, even if they have not yet been defined (no FORWARD declarations are necessary). It is in the responsibilty of the programmer to ensure that all necessary functions have been defined when the function is actually called. (*--------------------------------------------------------------------*) A function definition has the following form: function Funame(): Resulttype; begin end. Instead of function, one may also use the keyword procedure (for compatibility with Modula-2). Funame must be an admissible identifier, different from all ARIBAS keywords and names of builtin functions. (Also for compatibility with Modula-2, Funame may be repeated after the symbol end.) The formal parameter list may contain (as in Pascal or Modula-2) value and variable parameters. The parameter list may also be empty, however the pair of parentheses may not be omitted. The external, constant und variable declarations, which will be discussed later, may also be absent. The body of the function comes between the symbols begin and end. It may contain one or more return statements of the form return Retval; where Retval must have the data type Resulttype. In ARIBAS, also structured types (like arrays) may be used as Resulttype. Examples: (*--------------------------------------------------------------*) function mersenne(n: integer): integer; begin return 2**n - 1; end. (*--------------------------------------------------------------*) This function calculates the n-th Mersenne number. ==> mersenne(59). -: 576_46075_23034_23487 An alternative form of this function definition is (*--------------------------------------------------------------*) procedure mersenne(n: integer): integer; begin return 2**n - 1; end mersenne. (*--------------------------------------------------------------*) Remark: The period '.' at the end of the function definition is only necessary if one inputs the function definition directly at the ARIBAS prompt. If the function definition is in a file, which is loaded by ARIBAS (using the function load), one may also put a semicolon instead of the period. The following is a recursive function to calculate the factorial of n. (*--------------------------------------------------------------*) function fac_rec(n: integer): integer; begin if n <= 2 then return n; else return fac_rec(n-1)*n; end end. (*--------------------------------------------------------------*) Variable declarations --------------------- If the function needs local variables, they have to be declared as in the following example, which is an iterative version of the above function. function fac_it(n: integer): integer; var i,x: integer; begin x := 1; for i := 2 to n do x := x*i; end; return x; end. (*---------------------------------------------------------*) Using initializations in the variable declaration, this function could also have been written in the following way: function fac_it1(n: integer): integer; var i := 1; x := 1; begin while inc(i) <= n do x := x*i; end; return x; end. (*---------------------------------------------------------*) In contrast to Pascal, the lengths of arrays in variable declarations need not be constants. Example: (*---------------------------------------------------------*) function squarelist(n: integer): array; var k: integer; vec: array[n]; begin for k := 1 to n do vec[k-1] := k*k; end; return vec; end. (*---------------------------------------------------------*) This function generates an array of length n containing the square numbers from 1 to n**2. ==> squarelist(5). -: (1, 4, 9, 16, 25) In ARIBAS it is even possible to define functions that return a stack, as in the following example. (*---------------------------------------------------------*) function mk_stack(x: integer): stack; var st: stack; begin stack_push(st,x); return st; end. (*---------------------------------------------------------*) This function creates a stack of length 1 containing the integer x. ==> S := mk_stack(17). -: ==> stack_top(S). -: 17 (*---------------------------------------------------------*) External declarations --------------------- If one wants to access global variables from within functions, they must be declared in the external declaration. The same holds for user defined global constants. (This is a precautionary measure, since it is so easy to create global variables simply by assignments. Anyway, one should use global variables inside functions only exceptionally.) Example: (*---------------------------------------------------------*) function count(): integer; external Counter: integer; begin return inc(Counter); end; (*---------------------------------------------------------*) This is also an example of a function with empty argument list. It is supposed that the integer variable Counter exists when the function is called. ==> Counter := 7; count(). -: 8 At the same time, the variable Counter has been increased by 1. ==> Counter. -: 8 The same effect can be achieved by passing Counter as a variable parameter. (*---------------------------------------------------------*) function count1(var counter: integer): integer; begin return inc(counter); end; (*------------------------------------------------------------*) With the global variable Counter from above, we get ==> count1(Counter). -: 9 ==> Counter. -: 9 (*------------------------------------------------------------*) Constant declarations --------------------- Constant declarations within function definitions are placed after the external declarations and before the variable declarations. They have a syntax as in Pascal or Modula-2. However, ARIBAS allows for example also array contants. Example: (*------------------------------------------------------------*) function dayofweek(n: integer): string; const Week = ("SU", "MO", "TU", "WE", "TH", "FR", "SA"); begin return Week[n mod 7]; end; (*------------------------------------------------------------*) ==> dayofweek(4). -: "TH" (*------------------------------------------------------------*) Optional arguments of functions ------------------------------- In ARIBAS, it is possible to define functions with optional arguments. To do this, one must put assignments of the form := Val at the end of the formal parameter list instead of the usual type declarations for value parameters. If in a call of this function the corresponding argument is not supplied, Val is used as default value. If one supplies the argument, it may have any value of the same data type as Val. Example (*------------------------------------------------------------*) function ranvec(len: integer; bound := 1000): array; var vec: array[len]; i: integer; begin for i := 0 to len-1 do vec[i] := random(bound); end; return vec; end; (*------------------------------------------------------------*) This functions creates an array of length len whose components are random numbers. If the function is called only with the argument len, then the randon numbers are taken from the interval 0 <= x < 1000. If called with two arguments len and bound, the random numbers are taken in the range 0 <= x < bound. ==> ranvec(12). -: (923, 23, 510, 475, 970, 974, 5, 553, 175, 700, 891, 411) ==> ranvec(12,100). -: (15, 95, 55, 99, 17, 63, 7, 82, 24, 62, 49, 10) There may be more than one optional argument. (*------------------------------------------------------------*) function ran_vec(len := 10; bound := 1000): array; var vec: array[len]; i: integer; begin for i := 0 to len-1 do vec[i] := random(bound); end; return vec; end; (*------------------------------------------------------------*) This function may be called with zero, one or two arguments. ==> ran_vec(). -: (616, 446, 251, 397, 405, 516, 535, 220, 928, 703) ==> ran_vec(8). -: (366, 149, 680, 868, 297, 827, 466, 736) ==> ran_vec(8,60). -: (1, 50, 7, 11, 1, 45, 8, 11) (*------------------------------------------------------------*) 10) COMMAND LINE ARGUMENTS ========================== One can call ARIBAS with several command line arguments: aribas [options] [ [ ...]] The following options are available: -q (quiet mode) Suppresses all messages to the screen (version no, copyright notice, etc.) when ARIBAS is started -v (verbose mode, default) Does not suppress messages to the screen when ARIBAS is started. -c ARIBAS does its own line breaking when writing to the screen. Normally it supposes that the screen (or the window in which ARIBAS runs) has 80 columns. With the -c option you can set another number, which must be between 40 and 160 (in decimal representation). For example, if you run ARIBAS in an Xterm window with 72 columns, use the option -c72 (or -c 72, the space between -c and the number is optional). -m Here is a number (in decimal representation) between 64 and 16000. This number indicates how many Kilobytes of RAM ARIBAS should use for the ARIBAS heap. The default value depends on the options used when ARIBAS was compiled. Typically, under UNIX or LINUX it is 2 Megabytes, corresponding to -m2000 -h The online help of ARIBAS depends on a file aribas.hlp which should be situated (under MS-DOS) in the same directory as aribas.exe or (under UNIX) in the range of the environment variable PATH. If this is not the case you can specify the exact path of the help file with the -h option. If for example the file aribas.hlp is in the directory /usr/local/lib, use the option -h /usr/local/lib (the space after -h is not necessary). The -h option can also be used if the help file has a different name. If the help file is named help-aribas and lies in the directory /home/joe/ari, use -h/home/joe/ari/help-aribas . -p With this option you can specify a search path for loading files with ARIBAS source code. may be either the (absolute) pathname of one directory or several pathnames separated by colons (under UNIX) or semi-colons (under MS-DOS). Under UNIX, the user's home directory may be abbreviated by ~/ . Suppose (under UNIX) that you have called ARIBAS with the option -p/usr/local/lib/aribas:~/ari/examples and that your home directory is /home/alice/. Then the command ==> load("factor"). will search the file factor.ari first in the current directory, then in the directory /usr/local/lib/aribas and finally in /home/alice/ari/examples. Under MS-DOS, a typical example for the -p option looks like -pC:\aribas\examples;D:\work\ari -b Batch mode when loading an ARIBAS source code file from the command line, see below. One letter options which require no arguments may be merged, for example aribas -q -b is equivalent to aribas -qb The next command line argument after the options is interpreted as the name of a file with ARIBAS source code. If the file name has the extension .ari, this extension may be omitted. The file is loaded as if the command load("") had been given after the start of ARIBAS at the ARIBAS prompt. If the file is not found in the current directory it is searched in the directories specified by the -p option. If the option -b was given, the file is loaded and executed. Afterwards ARIBAS exits without showing it's prompt. If the file cannot be loaded completely because of an error, ARIBAS exits immediately after the error message. ... When further command line arguments follow , they are collected (as strings) together with in the vector ARGV which can be accessed from within ARIBAS. Example: If you call ARIBAS with the command line aribas startup 4536 eisenstein and the current directory contains the file startup.ari, then ARIBAS loads it and the vector ARGV has the form ==> ARGV. -: ("startup", "4536", "eisenstein") If you need some arguments as numbers and not as strings, you can transform them by atoi (or atof); in our example ==> x := atoi(ARGV[1]). -: 4536 will do it. The length of the vector ARGV can be determined by length(ARGV). Configuration file ------------------ Options for running ARIBAS can be specified also using a configuration file. Under UNIX, this file is named .arirc, under MS-DOS its name is aribas.cfg. ARIBAS searches for a configuration file in the following order: 1) current directory 2) Under UNIX: home directory of the user Under MS-DOS: directory containing aribas.exe Under UNIX, there is a third possibility: You can define an environment variable ARIRC containing the name of the configuration file (which may be different from .arirc) including the full path. In the configuration file you can specify all command line options described above which begin with a - sign, however a separate line must be used for every single option. Lines beginning with the character # or empty lines are ignored. In addition to the options described above, the configuration file may contain ARIBAS source code. For this purpose there must be a line reading -init Then everything after this line is treated as ARIBAS source code and executed when ARIBAS is started. The existence of a configuration file for ARIBAS does not exclude the possibility to give command line arguments. If an option (e.g. the -m option) is specified both in the configuration file and the command line but with different values, then the specification at the command line is valid. Analogously, a -v option on the command line overrides a -q option in the configuration file. If there is -init code in the configuration file and an argument at the command line, then the -init code is executed first and afterwards the is loaded and its code executed. (*************************** EOF ******************************) aribas165b/doc/aritut.txt0000644000076600000240000012146114660570651014423 0ustar ottostaffTUTORIAL ARIBAS Interpreter for Arithmetic, V1.65, Sep. 2018 written by 0. Forster, Email forster@rmathematik.uni-muenchen.de This tutorial gives a short introduction to ARIBAS. For more informations see the documentation in the file "aridoc.txt" INTRODUCTION ============ ARIBAS is an interactive interpreter suitable for big integer arithmetic and multiprecision floating point arithmetic. It has a syntax similar to Pascal or Modula-2, but contains also features from other programming languages like C, Lisp, Oberon. In ease of use it is comparable to Basic. There are versions of ARIBAS for LINUX, UNIX, MacOSX and MsWindows After the start of ARIBAS there appear some messages on the screen and the ARIBAS prompt ==> is displayed, indicating that ARIBAS is ready to accept your commands. IMPORTANT: To mark the end of your input, you must type a full stop '.' and then press the RETURN (ENTER) key. ARIBAS is case sensitive, so for example variables X and x are different. The command exit to leave ARIBAS must be given in lower case, however it is not necessary to put a full stop after exit. Arithmetic operators ==================== ARIBAS can be used like a pocket calculator. Simply enter the expression you want to calculate followed by a full stop and then press RETURN. Example: ==> 234 * 123. -: 28782 ARIBAS displays the sign -: to introduce the result. For exponentiation, ARIBAS uses the operator ** (as in FORTRAN). Example: ==> 2**127 - 1. -: 1701_41183_46046_92317_31687_30371_58841_05727 By the way, this is a prime number (found by Lucas in 1876). To store this number in a variable named p, one can use the following feature of ARIBAS: The three last results are always stored in the pseudo-variables _, __ and ___ (that is 1,2 or 3 underscores). Thus if you enter now ==> p := _. ARIBAS answers -: 1701_41183_46046_92317_31687_30371_58841_05727 Subsequently you may refer to this number simply by p, e.g. ==> p. -: 1701_41183_46046_92317_31687_30371_58841_05727 ==> p*p + 2**32. -: 28_94802_23093_29048_85589_27462_52171_97696_29772_13799_48920_25464_01021_ 39455_08091_65825 As you can see in these examples, ARIBAS structures the display of big integers (>= 2**32) by underscores. Also for the input of integers you may use underscores. The only condition is that the underscore appears between two digits (leading or trailing underscores are not allowed). Example: ==> x := 91_2_345678_0. -: 91234_56780 If you want to enter numbers which need more than one line, the last character before the end-of-line must be an underscore (you must type RETURN immediately after the underscore, spaces or tabs after the underscore are not allowed). The following line may begin with spaces and tabs, but the first character after these must be a digit. Example: ==> x := 120000000000000000000000000000_ 000000000000000000000000000000_ 0000000000000000000000000_1234. -: 1200_00000_00000_00000_00000_00000_00000_00000_00000_00000_00000_00000_ 00000_00000_00000_00000_00000_01234 Division: ==> 100/7. -: 14.2857143 The operator / denotes division in floating point mode. IMPORTANT: For integer division, use the operator div: ==> 100 div 7. -: 14 The remainder of the division is calculated by the operator mod: ==> 100 mod 7. -: 2 a div m is defined as the greatest integer <= a/m, the operators div and mod are connected by the equation a = (a div m) * m + (a mod m) Thus ==> -100 div 7. -: -15. ==> -100 mod 7. -: 5 ==> -100 div -7. -: 14 ==> -100 mod -7. -: -2 The operator mod and powers --------------------------- When calculating an expression a ** expo mod m ARIBAS does not calculate first a**expo and then reduce modulo m, but reduces all intermediate results modulo m which appear during the calculation of the power a**expo. Thus calculations are possible which would otherwise lead to overflows. Example: If p is a prime and a an integer relatively prime to p, then by the well known little theorem of Fermat one has a ** (p-1) = 1 modulo p. Let's verify this equation with the Lucas prime we calculated earlier. ==> p := 2**127 - 1. -: 1701_41183_46046_92317_31687_30371_58841_05727 ==> 123456 ** (p-1) mod p. -: 1 Of course this is true for arbitrary bases a (provided a is not a multiple of p). To get an `arbitrary' number a, one can use the function random: ==> a := random(10**8). -: 84808802 ==> a ** (p-1) mod p. -: 1 random(n) produces by means of a pseudo random generator a random integer x in the range 0 <= x <= n-1. Of course you will almost certainly get a different number when you call random(10**8). (The random generator may be controlled by the function random_seed, see the documentation.) Some builtin functions with integer arguments --------------------------------------------- The function isqrt(x) returns the biggest integer y such that y*y <= x. For example, the square root of 2 can be calculated with a precision of 500 decimal places using the command ==> isqrt(2*10**1000). -: 1_41421_35623_73095_04880_16887_24209_69807_85696_71875_37694_80731_76679_ 73799_07324_78462_10703_88503_87534_32764_15727_35013_84623_09122_97024_92483_ 60558_50737_21264_41214_97099_93583_14132_22665_92750_55927_55799_95050_11527_ 82060_57147_01095_59971_60597_02745_34596_86201_47285_17418_64088_91986_09552_ 32923_04843_08714_32145_08397_62603_62799_52514_07989_68725_33965_46331_80882_ 96406_20615_25835_23950_54745_75028_77599_61729_83557_52203_37531_85701_13543_ 74603_40849_88471_60386_89997_06990_04815_03054_40277_90316_45424_78230_68492_ 93691_86215_80578_46311_15966_68713_01301_56185_68987_23723 The result is 10**500 times the square root of 2, rounded downwards to the next integer. The function gcd(x,y) calculates the greatest common divisor of x and y. Example: ==> gcd(3**100+1,2**100-1). -: 41 Functions for factorization --------------------------- ARIBAS has stored internally all prime numbers < 2**16. If the integer x has a prime factor p < min(x,2**16), the command factor16(x) returns the smallest such factor. If such a prime factor doesn't exist, the return value is 0. Examples: ==> x := 91654327. -: 91654327 ==> factor16(x). -: 17 ==> x div 17. -: 5391431 ==> factor16(_). -: 17 ==> __ div _. -: 317143 ==> factor16(_). -: 83 ==> __ div _. -: 3821 ==> factor16(_). -: 0 ==> 17 * 17 * 83 * 3821. -: 91654327 The function factor16 may be called with two additional optional arguments. factor16(x,x0) searches only for prime factors >= x0 and factor16(x,x0,x1) only for prime factors p satisfying x0 <= p <= x1. The function prime32test(x) tests an integer x with 0 < x < 2**32 for primility. If x < 2**32 is prime, the function returns 1; if x < 2**32 is composite, 0 is returned. For x >= 2**32 the return value is -1. Examples: ==> 2**31 - 1. -: 2147483647 ==> prime32test(_). -: 1 ==> prime32test(2**32 - 1). -: 0 ==> prime32test(2**127 - 1). -: -1 There are other builtin factorization and primality testing algorithms, namely rho_factorize(x), cf_factorize(x), rab_primetest(x). Details can be found in the documentation or by using the Online Help of ARIBAS --------------------- For example, information about the function rho_factorize can be obtained by the command help(rho_factorize). You will get the following output: ==> help(rho_factorize). rho_factorize(x:integer [; b: integer]): integer; Tries to factorize x using Pollard's rho-algorithm. The optional argument b is a bound for the maximal number of steps (default value b = 2**16). If the algorithm finds a factor, it is returned, in case of failure the return value is 0. The number x should be free of small prime factors (e.g. < 1000). Then, if x has a prime factor p < sqrt(x), the algorithm will in general find a factorization of x if b is a small multiple of sqrt(p). If the return value y is > 1 and < x, it is certainly a factor of x, but not necessarily prime. SEE ALSO: cf_factorize, factor16 As an example, let us factorize the sixth Fermat number 2**64 + 1. ==> rho_factorize(2**64 + 1). working .. factor found after 512 iterations -: 274177 The command ==> symbols(aribas). -: (ARGV, _, __, ___, abs, alloc, and, arccos, arcsin, arctan, arctan2, aribas, array, atof, atoi, begin, binary, binsearch, bit_and, bit_clear, bit_count, bit_length, bit_not, bit_or, bit_set, bit_shift, bit_test, bit_xor, boolean, break, by, byte_string, cardinal, cf_factorize, char, chr, close, concat, const, continue, cos, dec, decode_float, div, divide, do, double_float, ec_factorize, else, elsif, end, even, exit, exp, extended_float, external, factor16, factorial, false, file, float, float_ecvt, floor, flush, for, frac, ftoa, function, gc, gcd, gcdx, get_filepos, get_floatprec, get_printbase, get_printprec, get_workdir, getenv, gf2X_div, gf2X_divide, gf2X_gcd, gf2X_mod, gf2X_modpower, gf2X_mult, gf2X_primetest, gf2X_square, gf2n_degree, gf2n_fieldpol, gf2n_init, gf2n_trace, gf2nint, gfp_sqrt, gmtime, halt, help, if, inc, integer, isqrt, itoa, jacobi, length, load, log, long_float, make_unbound, max, max_arraysize, max_floatprec, max_gf2nsize, max_intsize, mem_and, mem_bclear, mem_bitswap, mem_bset, mem_btest, mem_byteswap, mem_not, mem_or, mem_shift, mem_xor, memavail, min, mod, mod_coshmult, mod_inverse, mod_pemult, new, next_prime, nil, not, odd, of, open_append, open_read, open_write, or, ord, pi, pointer, prime32test, procedure, product, qs_factorize, rab_primetest, random, random_seed, read_block, read_byte, readln, real, realloc, record, return, rewind, rho_factorize, round, save_input, set_filepos, set_floatprec, set_printbase, set_printprec, set_workdir, sin, single_float, sort, sqrt, stack, stack2array, stack2string, stack_arraypush, stack_empty, stack_pop, stack_push, stack_reset, stack_top, stderr, stdin, stdout, string, string_scan, string_split, substr_index, sum, symbols, system, tan, then, timer, to, tolower, toupper, transcript, true, trunc, type, type_ident, user, var, version, while, write, write_block, write_byte, writeln) returns a list of names of builtin functions and other reserved words in ARIBAS. For almost all of the symbols in this list you can get a short online help with the command help(Topic), where Topic is one of the symbols in the above list. Let us do another example: ==> help(rab_primetest). rab_primetest(x: integer): boolean; Performs the Rabin probabilistic prime test. If the function returns false, the number is certainly composite. A 'random ' number x, for which factor16(x) = 0 and rab_primetest(x) = true is prime with high probability. An exception are numbers constructed purposely to fool the Rabin prime test. But also for these numbers the error probability is less than 1/4. To decrease the error probability, one can repeat the test several times. SEE ALSO: prime32test, factor16 As an application, consider the number ==> p := (2**64 + 1) div 274177. -: 6728_04213_10721 ==> rab_primetest(p). -: true Using other bases than 10 for the representation of integers ------------------------------------------------------------ Besides the decimal representation of integers, ARIBAS allows also hexadecimal (base 16), octal (base 8) and binary (base 2) representation of integers. For these bases special prefixes have to be used. The prefix is 0x for base 16, 0o for base 8 and 0y for base 2. (One can use also the upper case forms 0X, 0O, 0Y of the prefixes; however we recommend to use lower case.) Eaxamples: ==> 0xFACE. -: 64206 ==> 0y1111. -: 15 ==> 0o377. -: 255 The output is done by default in base 10, but this can be changed using the function set_printbase(b), where b must be one of the integers 2, 8, 10 or 16. Example: ==> x := 2**32 - 1. -: 4294967295 ==> set_printbase(16). -: 0x10 ==> x. -: 0xFFFF_FFFF ==> set_printbase(2). -: 0y10 ==> x. -: 0y11111111_11111111_11111111_11111111 ==> set_printbase(8). -: 0o10 ==> x. -: 0o3_77777_77777 ARIBAS provides also a series of builtin function for bit operations on integers, like bit_and, bit_or, bit_xor, bit_shift, etc. For these operations the integers are considered as bit sequences, i.e. to be in binary representation. For example, bit_and(x,0y11) returns the last 2 bits of x, which is equivalent to x mod 4. For more information, read the documentation or use the online help. Floating point numbers (reals) ============================== Besides integers, ARIBAS also supports floating point numbers (data type real). Floating point numbers are written in decimal representation and must contain a decimal point. Before and after the decimal point there must be at least one digit. Hence 2.0 and 0.2 are admissible, but .3333 is not. Optionally there may follow a scaling factor, consisting of the symbol E (or e) and an integer in decimal representation (no spaces are allowed between the digits and the symbol E). For example, 2.0E3 means the same as 2000.0 and 2.0e-3 is equivalent to 0.002. However 2E3 is not admissible (since there is no decimal point). For the arithmetic with real numbers there are the operators +, -, *, / and ** (exponentiation). As mentioned earlier for the operator / , there is sometimes an automatic type conversion from integer to real. Examples: ==> 3 + 4/3. -: 4.33333333 ==> 2**-2. -: 0.250000000 ==> 2 ** 0.5. -: 1.41421356 ARIBAS provides some builtin elementary algebraic and transcendental functions: sqrt (square root), log (natural logarithm), exp (exponential function), the trigonometric functions sin, cos und tan, and its inverse functions arcsin, arccos, arctan und arctan2. Examples: ==> sqrt(2). -: 1.41421356 ==> arctan(1). -: 0.785398163 ==> tan(_). -: 1.00000000 The constant pi is also available: ==> sin(pi/3). -: 0.866025404 ==> _*_. -: 0.750000000 (It is a well known fact that sine of pi/3 equals sqrt(3)/2 = sqrt(0.75).) If you let ARIBAS display the value of pi, you get the following result: ==> pi. -: 3.14159265358979323846264338327950288419716939937510582 This leads as to another topic. Calculating with multiple precision ----------------------------------- ARIBAS supports different types of floating point numbers which are internally represented with mantissas of different bit-length: single_float 32 bits double_float 64 bits long_float 128 bits extended_float 192 bits By default, single_floats are used (this corresponds to a precision of 9 to 10 decimal places, since 32*log(2)/log(10) = 9.63..). The precision can be changed by the function set_floatprec. The call has either the form set_floatprec(Float_type), where Float_type is one of the symbols short_float,...,extended_float or the form set_floatprec(bb), where bb is an integer denoting the desired float precision. If bb is not one of the numbers 32,...,192, then it is automatically rounded to the next higher resp. highest admissible precision. Example: ==> set_floatprec(long_float). -: 128 ==> 100/7. -: 14.2857142857142857142857142857142857 ==> exp(pi*sqrt(163)). -: 262537412640768743.999999999999250073 (It is a curious fact known from analytic number theory that exp(pi*sqrt(163)) is almost an integer.) ==> set_floatprec(50). -: 64 ==> pi/2. -: 1.57079632679489662 The counterpart to set_floatprec is the function get_floatprec. If called without arguments, the current float precision is returned. ==> get_floatprec(). -: 64 Please note that in ARIBAS, when a function has no argument, the pair of parenthesis may not be omitted. get_floatprec may also be called with a floating point number as argument. Then the return value is the precision which is used for storing this number. Example: ==> get_floatprec(pi). -: 192 Direct input of floating point numbers with precribed precision --------------------------------------------------------------- The command ==> x := 0.2. -: 0.200000000 stores the value 0.2 under the variable name x with the current float precision (which is single_float, if it has not been changed by set_floatprec). Using special exponent markers one can force another precision to be used. These exponent markers are: single_float F or f double_float D or d long_float L or l extended_float X or x (The exponent marker E denotes the current float precision.) Example: ==> z := 0.2x0. -: 0.200000000000000000000000000000000000000000000000000000 As a result, the number 1/5 is stored as an extended_float (i.e with a mantissa of 192 bits) under the variable name z. If the current precision is single_float, the comparison z = 0.2 returns ==> z = 0.2. -: false (Since reals are stored internally in binary representation, even a simple number like 0.2 is not stored exactly. However 0.5 or 0.125 would be stored without errors independently of the float precision.) Characters, strings =================== Besides integer and real numbers, characters and strings are important data types in ARIBAS. A character literal is given by enclosing the character between single quotes, e.g. ==> ch := 'X'. -: 'X' Another method to define a character is using the function chr, which transforms an (extended ASCII) code between 0 and 255 to the corresponding character. Example: ==> ch := chr(65). -: 'A' Be cautious with codes which denote non-printable characters, since they may be interpreted as control characters when output to the terminal. For example ==> write(chr(7)). -: 1 will in general (depending on the system) produce a beep. The result 1 indicates that one argument (the bell character) has been written to the terminal. The inverse function of chr is ord, e.g. ==> ord('X'). -: 88 Strings are finite sequences of characters. They have to be enclosed between double quotes, for example ==> str := "abcd". -: "abcd" The function length can be applied to strings and returns the number of characters in the string, e.g. ==> length(str). -: 4 The characters which compose the string are now accessible as str[i], where the index i runs from 0 to length(str)-1, in our example from 0 to 3. ==> str[2]. -: 'c' This can also be used to modify the string, e.g. ==> str[2] := 'X'. -: 'X' ==> str. -: "abXd" The function concat concatenates several strings or characters, for example ==> concat(str,'#',"123"). -: "abXd#123" This is a new string, the components remain untouched: ==> str. -: "abXd" Arrays ====== In ARIBAS it is easy to work with arrays. Array literals are given by enclosing a comma separated list of its components between parentheses, for example ==> vec := (2,3,4). -: (2, 3, 4) The components of this array are now vec[0], vec[1] and vec[2]. The indices of an array in ARIBAS always run from 0 to n-1, where n is the length of the array. This length can be determined by the builtin function length: ==> length(vec). -: 3 For arrays of length 1, braces must be used instead of parentheses. (This is necessary to distinguish vectors of length 1 from parenthesized expressions). Example: ==> vec1 := {2}. -: {2} (Also arrays of length /= 1 may be written with braces.) The components of an array don't have to be constants; also expressions are allowed. These expressions are then evaluated. Example: ==> n := 3; arr := (2**n, 3**n, 4**n). -: (8, 27, 64) As you can observe in this example, it is possible to enter several commands following the ARIBAS prompt. The commands must be separated by semicolons. The commands are executed one after the other. The result of the last command is printed after the result indicator -: Subarrays --------- For strings and arrays, not only single components can be accessed, but also whole subarrays. If vec is an array, then vec[n1..n2] denotes the subarray consisting of all components vec[i] with n1 <= i <= n2. Example: ==> vec := (1,2,3,4,5,6,7,8,9,10). -: (1, 2, 3, 4, 5, 6, 7, 8, 9, 10) ==> vec[2..6]. -: (3, 4, 5, 6, 7) Such subarray designators may also appear at the left hand side of an assignment and thus allow the simultaneous modification of all components of a subarray. ==> vec[2..6] := (-1,-2,-3,-4,-5). -: (-1, -2, -3, -4, -5) ==> vec. -: (1, 2, -1, -2, -3, -4, -5, 8, 9, 10). The boundaries of the subarray don't have to be constants; also expressions evaluating to integers are allowed. The upper boundary may be omitted. Then the subarray extends until the end of the array. An example for strings: ==> str := "ABCDEFGHIJK". -: "ABCDEFGHIJK" ==> concat(str[0..length(str) div 2 - 1], '_', str[length(str) div 2..]). -: "ABCDE_FGHIJK" More about arrays ----------------- The functions sum and product may be applied to arrays of integers or reals. They return the sum resp. the product of all components of the array. Example: ==> A := (1, 2, 3, 4, 5, 6, 7, 8, 9, 10); sum(A). -: 55 ==> product(A). -: 3628800 Arrays can be created not only by assigning array literals. Another way is by using the function alloc. The syntax is alloc(array, n, ele), where n is the length of the array and ele is an initial value for all components of the created array. The argument ele may be omitted; then the default value 0 is assumed. Example: ==> alloc(array,10). -: (0, 0, 0, 0, 0, 0, 0, 0, 0, 0) The initial value ele is not necessarily an integer; also values of other data types are admitted. For example ele may itself be an array, as in ==> mat := alloc(array,5,alloc(array,4)). -: ((0, 0, 0, 0), (0, 0, 0, 0), (0, 0, 0, 0), (0, 0, 0, 0), (0, 0, 0, 0)) This creates a (5 x 4)-matrix. The components of this matrix are mat[i][j] with 0 <= i <= 4, 0 <= j <= 3. These components may now be filled with new values, e.g. ==> for i := 0 to 4 do for j := 0 to 3 do mat[i][j] := 10*i + j; end; end; mat. -: ((0, 1, 2, 3), (10, 11, 12, 13), (20, 21, 22, 23), (30, 31, 32, 33), (40, 41, 42, 43)) Here we have anticipated the for loop, which will be discussed in the section on control structures. As the above example shows, the input to ARIBAS can extend over several lines. To faciltate to handle such input, the MS-DOS version of ARIBAS has a builtin mini-editor which we describe next. Builtin mini-editor (MS-DOS version) ==================================== In the MS-DOS version of ARIBAS, the input between the prompt ==> and the final full stop can be edited, even if it extends over several lines (up to 50 lines are possible, that is two screenfuls). The cursor (arrow) keys (CurRight, CurLeft, CurUp, CurDown) allow to move within the text. The HOME key moves to the beginning of a line, the END key to the end of line. CTRL-CurRight moves to the beginning of the next word, CTRL-CurLeft to the beginning of the previous word. PageUp moves to the line of the prompt ==> or, if the prompt is outside the screen, moves to the first line on the screen. PageDown moves to the last line on the screen. CTRL-PageUp moves to the beginning, CTRL-PageDown to the end of input. The RETURN, BACKSPACE and DELETE key have the usual meaning. The TAB key moves to the next tabulator position (the distance between two adjacent tabulator positions is 4 columns), SHIFT-TAB moves to the previous tabulator position. CTRL-Y deletes the current line, CTRL-T deletes from the current cursor position to the end of word. To finish an input, one can proceed as follows: First press CTRL-PageDown to move to the end of text. If a full stop has not yet been set, type one. Then press the RETURN key. In the same way as ARIBAS stores the three last results in the pseudo-variables _, __ and ___, also the three most recent inputs are stored. They can be retrieved using the function keys CTRL-F1, CTRL-F2 and CTRL-F3 respectively, and edited again. A drawback of this method is that one cannot refer to inputs that were made earlier. To enable this, there is a possibilty to assign the last input to one of the function keys ALT-F1, ALT-F2 and ALT-F3. This is done by the command ==> save_input(ch). Here ch must be one of the charactes 'a' (for ALT-F1), 'b' (for ALT-F2) or 'c' (for ALT-F3). Pressing ALT-Fk, one can retrieve these inputs any time (provided there has not been a reassignment). The function save_input can also be given a second argument, which must be one of the numbers 1, 2 or 3. save_input(ch,2) saves the second last input, save_input(ch,3) saves the third last input and save_input(ch,1) is equivalent to save_input(ch). Instead of assigning previous input to a function key ALT-Fk, it is possible to save the input to a file with extension .ari. To do this, the name of the file (the extension .ari may be omitted) is passed as an argument to save_input. For example, ==> save_input("a1"). stores the last input in the file a1.ari. Using the command ==> load_edit("a1"). the content of this file is brought back to the screen and may be edited further. The function load_edit can also load files which have been prepared by an external editor, provided that the number of lines is smaller than 50 and every line has a length <= 78. GNU-Emacs-Interface of ARIBAS (UNIX or LINUX version) ===================================================== If you are using the UNIX or LINUX version of ARIBAS and are familiar with the Emacs editor, then you should run ARIBAS from within Emacs. If the Emacs interface of ARIBAS has been properly installed, you can start ARIBAS from within Emacs by the command META-X run-aribas (if you don't have a META key, use ESC X instead of META-X). Then a buffer named *aribas* is created in a new window, in which ARIBAS starts and shows its prompt ==> You can then edit your input using the usual Emacs commands. Putting a full stop at the end and pressing RETURN sends the input to ARIBAS. (Under rare circumstances you don't want your input to end with a full stop, for example in response to a readln(s) command. Then you can send the input to ARIBAS by pressing CTRL-J.) To send a CTRL-C to ARIBAS, you have to press CTRL-C twice. META-P cycles backward and META-N forward through input history. This can be used if you want to repeat previous input or modify previous input. Running ARIBAS from the UNIX command line ========================================= If you start ARIBAS (UNIX or LINUX version) from the command line, then when doing multiline input you cannot go back to previous lines and can edit only the current line of input. This inconvenience can be overcome if you are running UNIX in a windowing system like X-Windows. Then you should run ARIBAS in one window and start your favorite text editor in a second window. There you prepare multiline input with the text editor and copy it by the cut and paste commands of the windowing system to the ARIBAS prompt in the other window. Transcript ========== It is possible to store all input and output during an ARIBAS session in a file, which can afterwards be examined and edited by loading it into an external editor. For this purpose serves the command ==> transcript(). This causes all subsequent interaction with ARIBAS to be recorded in a file aribas.log in the current directory. If a file of this name exists already, its previous content is lost. If you want to transcribe the session in a file with a different name, this filename must be given as an argument to the function transcribe; the extension .log may be omitted. For example ==> transcript("a1"). will transcribe the session in the file a1.log. The command ==> transcript(0). stops transcription and closes the log file. The end of an ARIBAS session closes the log file automatically. Control Structures ================== Loops ----- For the programming of iterations, ARIBAS offers the for and the while loop The for loop ------------ The syntax is for Runvar := Start to Last do end; Here Runvar is an integer variable, whereas Start and Last are integer expressions. Example: ==> x := 1; for i := 2 to 100 do x := x * i; end; x. -: 933_26215_44394_41526_81699_23885_62667_00490_71596_82643_81621_46859_ 29638_95217_59999_32299_15608_94146_39761_56518_28625_36979_20827_22375_82511_ 85210_91686_40000_00000_00000_00000_00000 This example calculates the factorial of 100. An extended form of the for loop is the following: for Runvar := Start to Last by Incr do end; Here Incr is an integer expression which must be different from 0. (The simple form of the for-loop corresponds to Incr = 1.) For example, ==> x := 1; for i := 100 to 2 by -1 do x := x*i; end; x. yields the same result as above (namely the factorial of 100), and ==> x := 1; for i := 1 to 100 by 2 do x := x*i; end; x. -: 2725_39213_97507_29502_98071_32454_00918_63329_07963_30545_80341_37343_ 28823_44310_62011_71875 calculates the product of all odd numbers from 1 to 99. The while loop -------------- The Syntax is while do end The boolean expression may be for example an arithmetic relation (like x < y) or may be built up from simpler boolean expressions using the boolean operators and, or, not. Example: ==> n := 1; x := 1; while n <= 100 do x := x*n; inc(n); end; x. This sequence of commands calculates the factorial of 100 as does the for loop considered earlier. Here inc(n) is equivalent to n := n+1; analogously dec(n) is an abbreviation of n := n-1. If in the above while loop the command inc(n) were left out, this would produce an infinite loop. How to get out of such an infinite loop? Under MS-DOS (or on the ARARI) press simultaneously the left CONTROL and SHIFT key, under UNIX (and LINUX) press CONTROL-C. (If ARIBAS is run from within Emacs, CONTROL-C must be pressed twice.) In general, this will abort the loop and you will get the message user interrupt ** RESET ** and a new prompt ==> appears, so you can try once again. In ARIBAS there is no repeat .. until loop. Such a loop can always be substituted by a suitable while loop. When using the while loop, the following feature of ARIBAS is sometimes useful: In every place, where ARIBAS expects a boolean value, one can also use integers. In this case 0 is considered as false and every nonzero integer counts as true (this is the same behaviour as in the programming language C). As an example, consider the following code, which calculates the prime factorization of x. ==> x := 10**11 + 1; q := 2; while q := factor16(x,q) do writeln(q); x := x div q; end; x. 11 11 23 4093 -: 8779 The function factor16(x,q) searches the smallest prime factor of x which is >= q and < min(2**16,x). If such a factor does not exist, the function returns 0. The assignment q := factor16(x,q) as a whole has an integer value, namely the new value of q. Therefore, if a prime factor is found, this expression counts as true and the commands in the body of the loop are executed. If no more prime factor is found, the value of the assignment is 0, which counts as false; therefore the loop is terminated. In the above example the last quotient x is smaller than 2**32, hence it must be prime. So the complete prime factorization of 10**11 + 1 has been found. If statements ------------- The general if statement has the following form (as in Modula-2): if then elsif then elsif then ... elsif then else end There may be arbitrarily many (perhaps 0) elsif parts (please note the spelling elsif); the else part may also be absent. Example: ==> for i := 0 to 10 do if i mod 3 = 0 then writeln("red"); elsif i mod 3 = 1 then writeln("green"); else writeln("yellow"); end; end. red green yellow red green yellow red green yellow red green yellow red green The for loop doesn't return a proper result; however the writeln statements, which work as in Pascal, cause as a side effect the output of the sequence red, green, ... . By the way, ARIBAS is very tolerant regarding semicolons (in contrast to Pascal). In the above code all the semicolons before elsif, else and end could have been omitted without changing the effect. User defined functions ====================== It is easy to define new functions in ARIBAS which can subsequently be used in the same way as builtin functions. Let us start with a simple example: ==> function mersenne(n: integer): integer; begin return 2**n - 1; end. -: mersenne The answer -: mersenne indicates that ARIBAS has accepted this function definition and has stored it without reporting an error (however the absence of an error message is no guarantee for the correctness). As you can see, the return statement return is used to supply the result (return value) of the function. An example call of mersenne: ==> mersenne(127). -: 1701_41183_46046_92317_31687_30371_58841_05727 (This is the Lucas prime already mentioned earlier.) The default data type of ARIBAS is integer. The explicit declaration of this type may be omitted. Hence the following function definition is equivalent to the definition above: ==> function mersenne(n); begin return 2**n - 1; end. -: mersenne (One could even omit all semicolons.) However we do not recommend using this short form. If a function needs local variables, they have to be declared. Example: ==> function fac(n: integer): integer; var x,i: integer; begin x := 1; for i := 2 to n do x := x*i; end; return x; end. -: fac ==> fac(100). -: 933_26215_44394_41526_81699_23885_62667_00490_71596_82643_81621_46859_ 29638_95217_59999_32299_15608_94146_39761_56518_28625_36979_20827_22375_82511_ 85210_91686_40000_00000_00000_00000_00000 Instead of function, also the keyword procedure may be used (as in Modula-2). Also for compatibility with Modula-2, the function name may be repeated at the end. Thus the above definition of the function fac is equivalent to ==> procedure fac(n: integer): integer; var x,i: integer; begin x := 1; for i := 2 to n do x := x*i; end; return x; end fac. In contrast to Pascal or Modula-2, nested function definitions are not allowed in ARIBAS. All functions have to be defined at top level (as in the programming language C). User defined global variables which are needed inside functions and which are not passed as arguments, can be used only if they are explicitly declared as external. The external declaration comes before the variable declaration. Example: ==> function foo(n: integer); external Counter: integer; var i: integer; begin inc(Counter); for i := 1 to n do write(i*i,"; "); end; end. -: foo On each call, this function increases the global integer variable Counter, which is supposed to exist, by 1. The predefined constants true, false and pi can be used without an external declaration. Inside functions one can use not only builtin functions, but also other user defined functions, even if they are defined only later (no FORWARD declaration is needed). It is in the responsibility of the programmer to insure that the other functions have been defined when the actual function call is done. Otherwise a runtime error will be generated. Example: ==> function foo(n: integer): integer; begin if n <= 0 then return 0; else return bar(n); end; end. -: foo ==> function bar(n: integer): integer; begin writeln(n); return foo(n-1); end. -: bar Here the functions foo and bar call each other recursively. ==> foo(5). 5 4 3 2 1 -: 0 As an extension to the capabilities of Pascal or Modula-2, a function in ARIBAS can return not only scalar types but also composite data types like strings or arrays. For example, consider the problem of multiplication of Gaussian integers n + mi, (where n,m are integers and i = sqrt(-1)). We represent such a number n+mi by an integer array (n,m) of length 2. Then the multiplication can be implemented as follows: ==> function gauss_mult(x,y: array[2]): array[2]; begin return (x[0]*y[0] - x[1]*y[1], x[0]*y[1] + x[1]*y[0]); end. -: gauss_mult ==> gauss_mult((2,3),(1,-2)). -: (8, -1) The following function reflects a string, i.e. returns a string which is the argument string read from right to left: ==> function reverse(s: string): string; var n,i: integer; temp: char; begin n := length(s); for i := 0 to (n div 2)-1 do temp := s[i]; s[i] := s[n-1-i]; s[n-1-i] := temp; end; return s; end. -: reverse ==> reverse("123456"). -: "653421" Note that this function does not change its argument string, since the argument is passed as a value parameter and the function works on a private copy of it. ==> s := "abc"; s1 := reverse(s). -: "cba" ==> s. -: "abc" If one wants to modify the argument, it has to be passed as a variable parameter. This is done (as in Pascal or Modula-2) by using the keyword var: ==> function reverse0(var s: string): string; var n,i: integer; temp: char; begin n := length(s); for i := 0 to (n div 2)-1 do temp := s[i]; s[i] := s[n-1-i]; s[n-1-i] := temp; end; return s; end. -: reverse0 ==> s := "abc"; s1 := reverse0(s). -: "cba" ==> s. -: "cba" One more example: ==> function double(var x: integer): integer; begin x := 2*x; return x; end. -: double ==> x := 123456; double(x). -: 246912 ==> x. -: 246912 In variable declarations inside function definitions the lengths of arrays may depend on the function's arguments, as in the following example: ==> function index_vector(n: integer): array; var i: integer; vec: array[n]; begin for i := 0 to n-1 do vec[i] := i+1; end; return vec; end. -: index_vector This function creates a vector of length equal to the argument n of the function whose components are the integers from 1 to n. ==> index_vector(20). -: (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20) Loading Files ------------- For bigger programming projects it is advisable to prepare the source codes with an external editor and save them in files with the extension .ari. Such a file can then be loaded from within ARIBAS. This is done with the function load, which is used as follows: ==> load(). Here is the name of the file as a string (enclosed between double quotes "..."). The extension .ari may be omitted. Suppose that there exists a file named fib.ari in the current directory which contains definitions of three functions fib_rec, fib_it und fib. This file can then be loaded with the following command: ==> load("fib"). fib_rec fib_it fib -: true The statements in the file (in our case the definitions of the functions fib_rec, fib_it und fib) are read in succession and evaluated. The result true indicates that the file has been successfully loaded. Now the functions fib_rec, fib_it and fib can be used as if their definitions had been input directly at the ARIBAS prompt. Comments: Source code in files should always be fully commented. In ARIBAS, comments are enclosed between the comment brackets (* and *). All text between the symbol (* and the next following *) is considered as a comment and ignored by ARIBAS. Comments may extend over several lines. Nested comments are not allowed. ERRORS ====== When writing program code, one almost inevitably commits errors. To be able to correct these errors more easily, it is advisable to write and test program code in small units. Suppose you have written the following function definition at the beginning of a file named test1.ari. function fac(n: integer): integer; var x,i: integer; begin x := 1; for i := 2 to n then x = x*i; end; return x; end. When you load this file by ==> load("test1"). you will get the following error messages: error in line <= 8 of loaded file for: do expected error in line <= 8 of loaded file function: syntax error -: false You should pay attention only to the first error message, since the following might be spurious errors caused by the first one. In our example an error in the for loop has occurred, which ARIBAS has located in line <= 8. In fact, in line 7, instead of 'do' there is the erroneous keyword 'then'. When you correct this error and load the file again, ==> load("test1"). fac -: true the file is accepted by ARIBAS without complaints. A test yields ==> fac(100). -: 1 which is obviously false. This time the error is more difficult to find. It is hidden in the line x = x*i; where the colon of the assignment operator is missing. Hence this statement is only a comparison between the numbers x and x*i. Although this comparision is useless, it is syntactically correct and therefore not criticized by ARIBAS. It is clear that such an error would be very hard to detect if you had already written several interdependent functions which were all syntactically correct but which have not been individually tested for semantic correctness. (********************************* EOF ******************************) aribas165b/doc/README0000644000076600000240000000102214660570651013220 0ustar ottostaffThis directory contains the files aritut.txt this is a short tutorial as an introduction to ARIBAS aridoc.txt this is a more systematic documentation of ARIBAS. Both files aritut.txt and aridoc.txt are pure ASCII files. aribas.hlp needed for online help from within ARIBAS. Must be placed in a directory which is in the PATH variable. aribas.1 Unix man page for aribas in troff format. Should be placed in directory /usr/man/man1 or /usr/local/man/man1 aribas.man ASCII version of aribas.1 aribas165b/EL/0000755000076600000240000000000014660570647012105 5ustar ottostaffaribas165b/EL/aribas.el0000644000076600000240000001555514660570647013703 0ustar ottostaff;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; aribas.el ;; Elisp code for running ARIBAS from within GNU Emacs (v. 19.xx) ;; 96-02-20, Otto Forster ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; To be able to run ARIBAS from within Emacs, this file must ;; be in the load-path of Emacs. If this is not the case, you ;; can extend the load-path by customizing your .emacs file. ;; If for example aribas.el is in the directory /usr/local/lib/aribas, ;; then write the following Elisp command into .emacs ;; ;; (setq load-path (cons "/usr/local/lib/aribas" load-path)) ;; ;; If aribas.el is in the subdirectory el of your home directory, ;; you can write ;; ;; (setq load-path (cons (expand-file-name "~/el") load-path)) ;; ;; Furthermore, put the following lines into your .emacs file ;; ;; (autoload 'run-aribas "aribas" ;; "Run ARIBAS." t) ;; ;; Then, after the next start of Emacs, you can run ARIBAS ;; by giving the command ;; ;; M-x run-aribas ;; ;; (If you don't have a META key, use ESC x instead of M-x) ;; Then ARIBAS will be loaded into an Emacs window with name ;; *aribas* and you can edit your input to ARIBAS. ;; If your input ends with a full stop '.' and you press RETURN, ;; it is sent to ARIBAS. ;; If however your complete input does not end with a full stop, ;; (for example in response to a readln), the input is sent ;; to ARIBAS by C-j (Control-j) or C-c RETURN. ;; If you want to repeat a previous input, M-p cycles backward ;; through input history, and M-n cycles forward. ;; A Control-C is sent to ARIBAS by C-c C-c (press C-c twice). ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require 'comint) (defvar aribas-mode-hook nil "*Hook for customising aribas-mode.") (defvar aribas-input-prompt "^==>[ \t]*") (defun aribas-input-complete () ;; check if point is at input end (let* ((res nil) (savepoint (point)) (str1 (buffer-substring savepoint (progn (end-of-line) (point)))) (str2 (buffer-substring (progn (beginning-of-line) (point)) savepoint))) (cond ((not (string-match "^[ \t]*$" str1))) ((or (string-match ".*\\.[ \t]*$" str2) (string-match ".*\\?[ \t]*$" str2) (string-match "exit[ \t]*$" str2)) (setq res t))) (goto-char savepoint) res)) (defun aribas-newline-or-send-input () (interactive) (if (aribas-input-complete) (comint-send-input) (newline))) (defun aribas-tab () "Indent to next tab stop." (interactive) (indent-to (* (1+ (/ (current-indentation) aribas-indent)) aribas-indent))) (defvar aribas-indent 4 "*This variable gives the indentation in aribas-mode") (defun aribas-mode-commands (map) (define-key map "\C-m" 'aribas-newline-or-send-input) (define-key map "\C-j" 'comint-send-input) (define-key map "\C-c\C-m" 'comint-send-input) (define-key map "\C-i" 'aribas-tab)) (defvar aribas-mode-map nil) (if aribas-mode-map nil ;; if aribas-mode-map has already been set, do nothing, ;; else do the following (setq aribas-mode-map (copy-keymap comint-mode-map)) (aribas-mode-commands aribas-mode-map)) (defvar aribas-mode-syntax-table nil "Syntax table in use in aribas-mode buffers.") (if aribas-mode-syntax-table nil (let ((table (make-syntax-table))) (modify-syntax-entry ?\( ". 1" table) (modify-syntax-entry ?\) ". 4" table) (modify-syntax-entry ?* ". 23" table) (modify-syntax-entry ?+ "." table) (modify-syntax-entry ?- "." table) (modify-syntax-entry ?= "." table) (modify-syntax-entry ?% "." table) (modify-syntax-entry ?< "." table) (modify-syntax-entry ?> "." table) (modify-syntax-entry ?_ "w" table) (modify-syntax-entry ?\\ "_" table) (modify-syntax-entry ?! "_" table) (modify-syntax-entry ?? "_" table) (modify-syntax-entry ?$ "'" table) (modify-syntax-entry ?& "'" table) (modify-syntax-entry ?\' "/" table) (setq aribas-mode-syntax-table table))) (defun aribas-mode () "Major mode for interacting with Aribas process. An Aribas process can be fired up with M-x run-aribas. Customisation: Entry to this mode runs the hooks on comint-mode-hook and aribas-mode-hook (in that order). Commands: RETURN after the end of an input ending with a full stop `.' sends the text from the aribas prompt to point to ARIBAS. If the input does not end with a full stop, RETURN produces a newline. CTRL-J sends the text from the aribas prompt to point to ARIBAS. CTRL-C CTRL-C sends a Control-C to ARIBAS. META-P cycles backwards in input history, META-N cycles forward." (interactive) (comint-mode) ;; Customise in aribas-mode-hook (setq comint-prompt-regexp aribas-input-prompt) (aribas-mode-variables) (setq major-mode 'aribas-mode) (setq mode-name "Aribas") (setq mode-line-process '(": %s")) (set-syntax-table aribas-mode-syntax-table) (use-local-map aribas-mode-map) (setq comint-scroll-to-bottom-on-output 'this) (setq comint-scroll-show-maximum-output t) (setq comint-input-autoexpand nil) (setq comint-input-filter (function aribas-input-filter)) (setq comint-input-sentinel (function ignore)) (setq comint-get-old-input (function aribas-get-old-input)) (setq case-fold-search nil) (run-hooks 'aribas-mode-hook)) (defun aribas-input-filter (str) t) (defun aribas-mode-variables () ) (defun aribas-args-to-list (string) (let ((where (string-match "[ \t]" string))) (cond ((null where) (list string)) ((not (= where 0)) (cons (substring string 0 where) (aribas-args-to-list (substring string (+ 1 where) (length string))))) (t (let ((pos (string-match "[^ \t]" string))) (if (null pos) nil (aribas-args-to-list (substring string pos (length string))))))))) (defvar aribas-program-name "aribas" "*Program invoked by the run-aribas command") (defun run-aribas (cmd) "Run aribas process, input and output via buffer *aribas*. If there is a process already running in *aribas*, just switch to that buffer. With argument, allows you to edit the command line (default is value of aribas-program-name). Runs the hooks from aribas-mode-hook \(after the comint-mode-hook is run). \(Type \\[describe-mode] in the process buffer for a list of commands.)" (interactive (list (if current-prefix-arg (read-string "Run aribas: " aribas-program-name) aribas-program-name))) (if (not (comint-check-proc "*aribas*")) (let ((cmdlist (aribas-args-to-list cmd))) (set-buffer (apply 'make-comint "aribas" (car cmdlist) nil (cdr cmdlist))) (aribas-mode))) (setq aribas-buffer "*aribas*") (switch-to-buffer "*aribas*")) (defun aribas-get-old-input () (save-excursion (let ((mark (point))) (re-search-backward comint-prompt-regexp (point-min) t) (comint-skip-prompt) (buffer-substring (point) mark)))) (provide 'aribas) ;;; aribas.el ends here ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; aribas165b/EL/README0000644000076600000240000000263114660570647012767 0ustar ottostaffThe file aribas.el provides the Emacs interface for ARIBAS To be able to run ARIBAS from within Emacs, the file aribas.el must be in the load-path of Emacs. If this is not the case, you can extend the load-path by customizing your .emacs file. If for example aribas.el is in the directory /usr/local/lib/aribas, then write the following Elisp command into .emacs (setq load-path (cons "/usr/local/lib/aribas" load-path)) If aribas.el is in the subdirectory el of your home directory, you can write (setq load-path (cons (expand-file-name "~/el") load-path)) Furthermore, put the following lines into your .emacs file (autoload 'run-aribas "aribas" "Run ARIBAS." t) Then, after the next start of Emacs, you can run ARIBAS from within Emacs by giving the command M-x run-aribas (If you don't have a META key, use ESC x instead of M-x) Then ARIBAS will be loaded into an Emacs window with name *aribas* and you can edit your input to ARIBAS with the usual Emacs commands. If your input ends with a full stop '.' and you press RETURN, it is sent to ARIBAS. If however your complete input does not end with a full stop, (for example in response to a readln), the input is sent to ARIBAS by C-j (Control-j) or C-c RETURN. If you want to repeat a previous input, M-p (or ESC p) cycles backward through input history, and M-n (or ESC n) cycles forward. A Control-C is sent to ARIBAS by C-c C-c (press C-c twice). aribas165b/examples/0000755000076600000240000000000014660572003013407 5ustar ottostaffaribas165b/examples/factor.ari0000644000076600000240000003055014660570647015401 0ustar ottostaff(****************************************************************) (* ** ARIBAS code for ** several factoring routines for integers ** author: Otto Forster ** date of last change: 2007-08-23 ** ** This code is place under the GNU general public license (GPL) *) (****************************************************************) (* ** The factoring algorithms ** p1_factorize, pp1_factorize, ECfactorize ** and the Aribas builtin functions ** rho_factorize, ec_factorize, cf_factorize and qs_factorize ** should be applied only to numbers which are not prime. ** This can be tested by rab_primetest or ss_test ** Also, before applying one of these factoring algorithms, ** one should first do trial division by small primes, ** for example using the function trialdiv (below). ** ** Example calls: ** ** ==> trialdiv(10**15+1). ** ==> factorlist(2**171-1) ** ==> p1_factorize(2**67-1). ** ==> pp1_factorize(2**67-1). ** ==> ECfactorize(2**256+1, 4000, 32000). *) (*--------------------------------------------------------------*) (* ** Trial division by primes p < 2**16 ** Constructs an array of factors of x. ** All elements with possible exeption of the last, ** are prime factors < 2**16. If the last element ** in the array is < 2**32, it is a prime. ** The product of all elements in the array equals x. *) function trialdiv(x: integer): array; var st: stack; q: integer; begin q := 2; while q := factor16(x,q) do stack_push(st,q); x := x div q; end; stack_push(st,x); return stack2array(st); end; (*--------------------------------------------------------------*) (* ** Constructs a list of all prime factors of x. ** If a prime p is a multiple factor of x, ** it is listed repeatedly according to its multiplicity. ** In case of failure, the empty list () is returned ** ** Uses trial division, rho_factorize and qs_factorize. ** ** This function writes a progress report to the screen, ** which can be suppressed by setting the last argument verbose = 0. *) function factorlist(x: integer; verbose := 1): array; var st, st1: stack; q, y, bound: integer; vec: array; count: integer; begin x := abs(x); if x < 2 then return (); end; q := 2; while q := factor16(x,q) do stack_push(st,q); x := x div q; if verbose then writeln(q); end; end; if x < 2**32 then stack_push(st,x); if verbose then writeln(x); end; else stack_push(st1,x); end; while not stack_empty(st1) do x := stack_pop(st1); if rab_primetest(x) then stack_push(st,x); if verbose then writeln(x); end; else bound := bit_length(x); bound := 4*bound**2; if verbose then writeln("trying to factorize ",x," using Pollard rho") end; y := rho_factorize(x,bound,verbose); count := 0; while (y <= 1 or y >= x) do if inc(count) > 2 then writeln("unable to factorize ",x); return (); end; if verbose then writeln("trying to factorize ",x, " using quadratic sieve"); end; y := qs_factorize(x,verbose); end; if verbose then writeln("found factor ",y); end; stack_push(st1,x div y); stack_push(st1,y); end; end; vec := stack2array(st); return sort(vec); end; (*--------------------------------------------------------------*) (* ** Solovay-Strassen primality test ** The argument x must be a positive integer. ** This is a probabilistic test: ** If ss_test(x) returns false, then x is certainly not a prime. ** If however the result is true, then x is only probably prime. ** To increase the probabilty, one can repeat the test. *) function ss_test(x: integer): boolean; var b, j, u: integer; begin if even(x) then return false end; b := 2 + random(x-2); j := jacobi(b,x); u := b ** (x div 2) mod x; if j = 1 and u = 1 then return true; elsif (j = -1) and (u = x-1) then return true; else return false; end; end. (*--------------------------------------------------------------*) (* ** Produkt aller Primzahlen B0 < p <= B1 ** und aller ganzen Zahlen isqrt(B0) < n <= isqrt(B1) ** Diese Funktion wird gebraucht von den Funktionen ** p1_factorize, pp1_factorize und ECfactorize *) function ppexpo(B0,B1: integer): integer; var x, m0, m1, i: integer; begin x := 1; m0 := max(2,isqrt(B0)+1); m1 := isqrt(B1); for i := m0 to m1 do x := x*i; end; if odd(B0) then inc(B0) end; for i := B0+1 to B1 by 2 do if prime32test(i) > 0 then x := x*i end; end; return x; end; (*--------------------------------------------------------*) (* ** Pollard's (p-1)-factoring algorithm ** In general a prime factor p of x is found, if ** p-1 is a product of prime powers q**k <= bound *) function p1_factorize(x: integer; bound := 16000): integer; const anz0 = 128; var base, d, n, n0, n1, ex: integer; begin base := 2 + random(64000); d := gcd(base,x); if d > 1 then return d; end; writeln(); write("working "); for n0 := 0 to bound-1 by anz0 do n1 := min(n0 + anz0, bound); ex := ppexpo(n0,n1); base := base ** ex mod x; write('.'); flush(); if base <= 1 then return 0; else d := gcd(base-1,x); if d > 1 then writeln(); writeln("factor found with bound ",n1-1) return d; end; end; end; return 0; end; (*-----------------------------------------------------*) (* ** (p+1)-factoring algorithm *) function pp1_factorize(x: integer; bound := 16000): integer; const anz0 = 128; var base, d, n, n0, n1, ex: integer; begin base := 2 + random(64000); d := gcd(base,x); if d > 1 then return d; end; writeln(); write("working "); for n0 := 0 to bound-1 by anz0 do n1 := min(n0 + anz0, bound); ex := ppexpo(n0,n1); base := mod_coshmult(base,ex,x); write('.'); flush(); if base <= 1 then return 0; else d := gcd(base-1,x); if d > 1 then writeln(); writeln("factor found with bound ",n1-1) return d; end; end; end; return 0; end; (*-----------------------------------------------------------------*) (* ** Elliptic curve factorization with big prime variation. ** N is the number to be factored. ** bound and bound2 are bounds for the prime factors ** of the order of the randomly chosen elliptic curve. ** anz is the maximal number of elliptic curves tried ** Returns a factor of N or 0 in the case of failure *) function ECfactorize(N: integer; bound := 1000; bound2 := 10000; anz := 200): integer; var k, a, d: integer; begin write("working "); for k := 1 to anz do a := 3 + random(64000); d := gcd(a*a-4,N); if d = 1 then write('.'); flush(); d := ECfact0(N,a,bound); end; if d <= 0 then write(':'); flush(); d := ECbigprimevar(N,a,-d,bound2); end; if d > 1 and d < N then return d; end; end; return 0; end; (*-----------------------------------------------------------------*) (* ** Called by function ECfactorize, not to be called directly ** ** Faktorisierungs-Algorithmus mit der elliptischen Kurve ** y*y = x*x*x + a*x*x + x ** bound ist Schranke fuer die Primfaktoren der Elementezahl ** der elliptischen Kurve *) (*-----------------------------------------------------------------*) function ECfact0(N,a,bound: integer): integer; const anz0 = 128; var x, B0, B1, s, d: integer; xx: array[2]; begin x := random(N); for B0 := 0 to bound-1 by anz0 do B1 := min(B0+anz0,bound); s := ppexpo(B0,B1); xx := mod_pemult(x,s,a,N); if xx[1] = 0 then d := xx[0]; if d > 1 and d < N then writeln(); write("factor found with curve "); writeln("parameter ",a," and bound ",B1); end; return d; else x := xx[0]; end; end; return -x; end; (*--------------------------------------------------------------*) (* ** auxiliary function, called by ECfactorize *) function ECbigprimevar(N,a,x,bound: integer): integer; const Maxhdiff = (22, 36, 57); Maxbound = (15000, 31000, 1000000); var XX: array of array[2]; maxhdiff: integer; c, i, q, k, d: integer; P,Q,R: array[2]; begin k := length(Maxhdiff) - 1; while k > 0 and bound <= Maxhdiff[k-1] do dec(k); end; bound := min(bound,Maxbound[k]); maxhdiff := Maxhdiff[k]; XX := alloc(array,maxhdiff+1,(0,0)); c := ((x + a)*x + 1)*x mod N; P := (x,1); Q := ecN_dup(N,a,c,P); if Q[1] < 0 then return Q[0]; end; XX[1] := R := Q; for i := 2 to maxhdiff do R := ecN_add(N,a,c,R,Q); if R[1] < 0 then return R[0]; end; XX[i] := R; end; R := ecN_add(N,a,c,P,Q); (* R = 3*P *) if R[1] < 0 then return R[0]; end; d := 0; q := 3; while q < bound do k := 1; inc(q,2); while prime32test(q) /= 1 do inc(q,2); inc(k); end; R := ecN_add(N,a,c,R,XX[k]); if R[1] < 0 then d := R[0]; if d > 1 and d < N then writeln(); writeln("factor found with curve parameter ",a, ", bigprime q = ",q); end; break; end; end; return d; end; (*--------------------------------------------------------------*) (* ** auxiliary function, called by ECfactbpv ** ** Addition zweier Punkte P,Q auf der elliptischen Kurve ** c*y**2 = x**3 + a*x**2 + x (modulo N) ** Falls waehrend der Rechnung durch eine nicht zu N teilerfremde ** Zahl geteilt werden muss, wird ein Paar (d,-1) zurueckgegeben, ** wobei d ein Teiler von N ist. ** Sonst Rueckgabe der Summe P+Q = (x,y) mit 0 <= x,y < N. *) function ecN_add(N,a,c: integer; P,Q: array[2]): array[2]; var x1,x2,x,y1,y2,y,m: integer; begin if P = Q then return ecN_dup(N,a,c,P); end; x1 := P[0]; x2 := Q[0]; m := mod_inverse(x2-x1,N); if m = 0 then return (gcd(x2-x1,N),-1); end; y1 := P[1]; y2 := Q[1]; m := (y2 - y1)*m mod N; x := (c*m*m - a - x1 - x2) mod N; y := (- y1 - m*(x - x1)) mod N; return (x,y); end; (*-------------------------------------------------------------*) (* ** Verdopplung eines Punktes P auf der elliptischen Kurve ** c*y**2 = x**3 + a*x**2 + x (modulo N) ** Falls waehrend der Rechnung durch eine nicht zu N teilerfremde ** Zahl geteilt werden muss, wird ein Paar (d,-1) zurueckgegeben, ** wobei d ein Teiler von N ist. ** Sonst Rueckgabe von P+P = (x,y) mit 0 <= x,y < N. *) function ecN_dup(N,a,c: integer; P: array[2]): array[2]; var x1,x,y1,y,z,m,Pprim: integer; begin x1 := P[0]; y1 := P[1]; z := 2*c*y1; m := mod_inverse(z,N); if m = 0 then return (gcd(z,N),-1); end; Pprim := (((3*x1 + 2*a)*x1) + 1) mod N; m := Pprim*m mod N; x := (c*m*m - a - 2*x1) mod N; y := (- y1 - m*(x - x1)) mod N; return (x,y); end; (*------------------------------------------------------------------*) (* ** Multiplication of a point P on the elliptic curve ** c*y**2 = x**3 + a*x**2 + x (modulo N) ** by an integer s >= 1. ** If during the calculation a division by a number which is ** not coprime to N must be performed, the function returns ** immediately a pair (d,-1), where d is a divisor of N. *) function ecN_mult(N,a,c: integer; P: array[2]; s: integer): array[2]; var k: integer; Q: array[2]; begin if s = 0 then return (0,-1); end; Q := P; for k := bit_length(s)-2 to 0 by -1 do Q := ecN_dup(N,a,c,Q); if Q[1] < 0 then return Q; end; if bit_test(s,k) then Q := ecN_add(N,a,c,Q,P); if Q[1] < 0 then return Q; end; end; end; return Q; end; (*********************************************************************) aribas165b/examples/pi.ari0000644000076600000240000001012614660570647014530 0ustar ottostaff(****************************************************************) (* ** ARIBAS code to calculate pi to many decimal places ** author: Otto Forster ** ** Example call: ** ==> pi_chud(2000). *) (*--------------------------------------------------------------*) (* ** Algorithmen zur Berechnung von pi und der Eulerzahl e ** auf viele Dezimalen (n <= 20000). ** pi_machin(n) berechnet pi nach der Machinschen Formel ** auf n Dezimalstellen genau; ** pi_agm(n) benutzt zur Berechnung das arithmetisch-geometrische ** Mittel. ** pi_chud(n) benutzt eine Methode von Ramanujam-Chudnowski ** ** euler(n) berechnet e auf n Dezimalstellen. ** Der Funktionswert ist jeweils eine ganze Zahl. Diese entspricht ** gerundet 10**n-mal pi bzw. e. *) (*--------------------------------------------------------------*) (* ** Berechnet zz*log(2) *) function log2(zz) var x, u, k; begin x := 0; k := 0; u := (zz * 2**16 * 2) div 3 while u /= 0 do x := x + u div (2*k + 1); u := u div 9; inc(k); end; return x div 2**16; end. (*------------------------------------------------------*) (* ** Berechnet zz*arctan(1/n), wird von pi_machin benutzt *) function atan1(zz,n) var x, u, v, k, nn; begin x := 0; k := 0; nn := n*n; u := zz div n; while u /= 0 do v := u div (2*k + 1); if even(k) then x := x + v; else x := x - v; end; u := u div nn; inc(k); end; return x; end. (*------------------------------------------------------*) (* ** Berechnet pi * 10**n nach der Machinschen Formel ** ** Beispiel-Aufruf: pi_machin(1000). *) function pi_machin(n) var z1, x; begin z1 := 10**n * 2**16; x := 16 * atan1(z1,5) - 4 * atan1(z1,239); return x div 2**16; end. (*------------------------------------------------------*) (* ** Berechnet exp(1) * 10**n *) function euler(n) var zz, x, k; begin zz := 10**n * 2**16; x := zz * 2; k := 2; while zz /= 0 do zz := zz div k; x := x + zz; inc(k); end; return x div 2**16; end. (*------------------------------------------------------*) (* ** Berechnet pi * 10**n, ** benutzt arithmetisch-geometrisches Mittel ** quadratische Konvergenz ** ** Beispiel-Aufruf: pi_agm(1000). *) function pi_agm(n) var zz; begin zz := 10**n * 2**16; return piaux(zz) div 2**16; end. (*------------------------------------------------------*) (* ** Hilfsfunktion fuer pi_agm *) function piaux(zz) var s, a, atemp, b, c, i; begin s := 0; a := zz; b := isqrt(zz * (zz div 2)); c := (a - b) div 2; i := 1; while c /= 0 do writeln("eps(",i,") = ",c/zz); s := s + (2**i * c * c) div zz; atemp := a; a := (a + b) div 2; b := isqrt(atemp * b); c := (a - b) div 2; inc(i); end; return (4*a*a) div (zz - 2*s); end. (*------------------------------------------------------*) (* ** Hilfsfunktion fuer pi_chud *) function Saux(zz) const k1 = 545140134; k2 = 13591409; k4 = 100100025; k5 = 327843840; var A, n: integer; S: integer; begin A := zz*k1; S := A * k2; n := 1; while A > 0 do A := A * ((6*n-5)*(6*n-3)*(6*n-1)); A := A div (n*n*n); A := A div (k4*k5); if even(n) then S := S + A * (k2 + n*k1); else S := S - A * (k2 + n*k1); end; inc(n); end; return S div k1; end; (*--------------------------------------------------------*) (* ** pi auf n Dezimalstellen nach Chudnowsky/Ramanujan *) function pi_chud(n: integer): integer; const k3 = 640320; k6 = 53360; var zz: integer; x: integer; begin zz := 2**16 * 10**n; x := isqrt(zz*zz*k3)*k6; x := (zz * x) div Saux(zz); return (x div 2**16); end; (*--------------------------------------------------------*) aribas165b/examples/queens.ari0000644000076600000240000001071514660570647015424 0ustar ottostaff(**********************************************************************) (* ** ARIBAS code for the n queens problem ** author: Otto Forster ** date: 99-04-30 ** ** Example calls: ** ==> queens(9). ** ==> queensrand(20). *) (*--------------------------------------------------------------------*) (* ** n-Damenproblem: n Damen sind auf einem n-mal-n-Schachbrett so ** zu plazieren, dass sie sich nicht gegenseitig bedrohen. ** Aufruf: queens(n). ** Dabei ist n die Groesse des Brettes ** (z.B. n = 8; fuer n > 10 dauert die vollstaendige Loesung sehr lange) ** Die Loesungen werden als Vektoren (a1,a2,...,an) ausgegeben. ** Dieser Vektor bezeichnet die Stellung, in der in der i-ten Zeile ** eine Dame auf der ai-ten Spalte steht *) (*--------------------------------------------------------------------*) var NbSol: integer; end; function queens(n: integer): integer; external NbSol: integer; var i: integer; brett, rest: array[n]; begin NbSol := 0; for i := 0 to n-1 do rest[i] := i+1; end; queenshilf(brett,0,rest,n); writeln("number of solutions:"); return NbSol; end. (*--------------------------------------------------------------------*) function queenshilf(brett: array; n: integer; rest: array; m: integer) external NbSol: integer; var i, j, x: integer; begin if m = 0 then inc(NbSol); writeln(NbSol:4,": ",brett); else for i := 0 to m-1 do x := rest[i]; if freediag(x,brett,n) then brett[n] := x; for j := i+1 to m-1 do rest[j-1] := rest[j]; end; queenshilf(brett,n+1,rest,m-1); for j := m-1 to i+1 by -1 do rest[j] := rest[j-1]; end; rest[i] := x; end; end; end; end. (*------------------------------------------------------------------*) function freediag(x: integer; brett: array; n: integer): boolean; var i: integer; begin for i := 0 to n-1 do if abs(x - brett[i]) = n-i then return false; end; end; return true; end. (*------------------------------------------------------------------*) (* ** randomized version of queens ** example call: queensrand(17). *) function queensrand(n); var i: integer; brett, rest: array[n]; begin rest := random_perm(n); writeln(n," queens problem; ... thinking ..."); queenshilf1(brett,0,rest,n); return; end; (*------------------------------------------------------------------*) function random_perm(n: integer): array; var perm: array[n]; i, x, temp: integer; begin for i := 0 to n-1 do perm[i] := i+1; end; for i := 0 to n-1 do x := random(n-i); temp := perm[i+x]; perm[i+x] := perm[i]; perm[i] := temp; end; return perm; end; (*------------------------------------------------------------------*) function queenshilf1(brett: array; n: integer; rest: array; m: integer): integer; var i, j, x, res: integer; begin if m = 0 then display_board(brett); return 1; else for i := 0 to m-1 do x := rest[i]; if freediag(x,brett,n) then brett[n] := x; for j := i+1 to m-1 do rest[j-1] := rest[j]; end; res := queenshilf1(brett,n+1,rest,m-1); if res > 0 then return 1; end; for j := m-1 to i+1 by -1 do rest[j] := rest[j-1]; end; rest[i] := x; end; end; end; return 0; end. (*------------------------------------------------------------------*) function display_board(brett: array); var i, n: integer; begin n := length(brett); for i := 0 to n-1 do display_row(brett[i],n); end; end; (*------------------------------------------------------------------*) function display_row(k,n) var i: integer; begin write(" "); for i := 1 to k-1 do write(" ."); end; write(" D"); for i := k+1 to n do write(" ."); end; writeln(); end; (*------------------------------------------------------------------*) aribas165b/examples/README0000644000076600000240000000040014660570647014275 0ustar ottostaffThis directory contains some files with examples of ARIBAS source code. factor.ari several factoring routines pi.ari several algorithms for calculating pi to many decimal places queens.ari ARIBAS implementation of the n queens problem. aribas165b/gnugpl.txt0000644000076600000240000004307614660570646013653 0ustar ottostaff GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. aribas165b/install.txt0000644000076600000240000000533114660573301014004 0ustar ottostaffINSTALLATION of ARIBAS ARIBAS (Version 1.65b, Aug. 2024) Copyright (C) 1996-2020 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de WWW http://www.mathematik.uni-muenchen.de/~forster /*-----------------------------------------------------------------*/ Compilation The simplest way to compile ARIBAS is the following: Go to the subdirectory src This directory contains the necessary source files and a Makefile Give the command make This will produce the executable file aribas and some *.o files, which you can delete by the command make clean Read also the file README in the directory src, where also another way to compile ARIBAS is described. To run ARIBAS, only the executable file aribas is necessary. You can directly test it by the command ./aribas in this directory, Installation To run ARIBAS also outside this directory by the simple command aribas, you should move it to a directory which is in the PATH variable. For example, if you have the corresponding write permission, you could place it in /usr/local/bin. Alternatively, create a subdirectory bin in your home directory, if it doesn't already exist. To test whether this directory is in the PATH variable, you can give the command echo $PATH If you don't find this bin directory in this path, put the line PATH="$HOME/bin:$PATH" in your file .bash_profile or the corresponding file which is used for that purpose on your system. If you want to use online help from within ARIBAS, you need the file aribas.hlp (from the directory doc), which must also be placed in a directory which is in the PATH variable, for example in your own bin directory. There is also an interface to run ARIBAS within the GNU Emacs editor (version 19.xx or higher). The necessary Emacs Lisp file is aribas.el in the subdirectory EL. Please read the corresponding README file. ############################# EOF ################################### /*-----------------------------------------------------------------*/ aribas165b/README0000644000076600000240000000046614660570647012473 0ustar ottostaffThe directory src contains the necessary files to compile ARIBAS for UNIX workstations, LINUX and MacOS X. The directory doc contains some files for documentation. The directory examples contains three example files of ARIBAS code. The file gnugpl.txt contains the text of the GNU General Public License aribas165b/src/0000755000076600000240000000000014660574426012373 5ustar ottostaffaribas165b/src/alloc.c0000644000076600000240000006411014660570647013634 0ustar ottostaff/****************************************************************/ /* file alloc.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2018 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** alloc.c ** memory allocation and garbage collection functions ** ** date of last change ** 1995-03-29 ** 1996-10-04 changed iniconfig ** 1997-04-18 various SIZE defines, changed mvsymtab, tempfree ** 1997-09-06 memory allocation #ifdef M_LARGE ** 1997-12-26 small changes in iniconfig ** 1998-01-06 fixed small bug in moveobj ** 2002-04-05 changed some configuration constants ** 2010-01-30 ArrayStack ** 2018-10-03 Align8 */ #include "common.h" /*-------------------------------------------------------------*/ /* configuration constants */ #define SMALL_BLOCK0SIZE 4000 /* unit is sizeof(truc) = 4 */ #define MED_BLOCK0SIZE 8000 #define BIG_BLOCK0SIZE 16000 #define SMALL_BLOCKSIZE 12240 /* multiple of 255 */ #define MED_BLOCKSIZE 16320 /* multiple of 255, < 2**14 */ #define BIG_BLOCKSIZE 65280 /* multiple of 255, < 2**16 */ #ifdef M_SMALL #define HASHTABSIZE 509 /* size of hash table (prime) */ #define BLOCKMAX 16 #define ARIBUFSIZE 5000 /* size of bignum buffer (word2's) */ #define BLOCK0SIZE SMALL_BLOCK0SIZE #define BLOCKSIZE SMALL_BLOCKSIZE #define RESERVE 6000 /* soviel Bytes sollen freibleiben */ #define ARRAYSTKSIZE SMALL_BLOCKSIZE #define WORKSTKSIZE 6000 /* size of evaluation+work stack (word4's) */ #define ARGSTKSIZE 7000 /* size of argument+save stack (word4's) */ #endif #ifdef M_LARGE #include #define HASHTABSIZE 1009 /* size of hash table (prime) */ #define BLOCKMAX 200 /* must be < 255 */ #define BLOCK0SIZE BIG_BLOCK0SIZE #define BLOCKSIZE BIG_BLOCKSIZE #define RESERVE BIG_BLOCK0SIZE #define WORKSTKSIZE BIG_BLOCK0SIZE #define ARRAYSTKSIZE BIG_BLOCKSIZE #define ARGSTKSIZE BIG_BLOCK0SIZE #ifdef MEM #if (MEM >= 1) && (MEM <= 32) #define MEM_DEFAULT (MEM*1024) #endif #endif /* MEM */ #ifdef INTSIZE #if (INTSIZE >= 20) && (INTSIZE <= 300) #define ARIBUFSIZE (INTSIZE * 209) #else #define ARIBUFSIZE 10000 /* size of bignum buffer (word2's) */ #endif /* INTSIZE >= 20 .. */ #else #define ARIBUFSIZE 10000 #endif /* INTSIZE */ #endif /* M_LARGE */ #ifndef MEM_DEFAULT #ifdef ATARIST #define MEM_DEFAULT 512 #endif #ifdef MsDOS #define MEM_DEFAULT 300 #endif #ifdef DjGPP #define MEM_DEFAULT 2048 #endif #ifdef MsWIN32 #define MEM_DEFAULT 4096 #endif #ifdef genUNiX #define MEM_DEFAULT 4096 #endif #endif /* MEM_DEFAULT */ /*-------------------------------------------------------------*/ PUBLIC truc *Symbol; PUBLIC truc *Memory[BLOCKMAX+1]; PUBLIC trucptr *Symtab; /* symbol table */ PUBLIC size_t hashtabSize; PUBLIC truc *WorkStack; /* evaluation stack (also work stack) */ PUBLIC truc *ArrayStack, *ArrayStkCeil; PUBLIC truc *evalStkPtr, *workStkPtr, *arrayStkPtr; PUBLIC truc *ArgStack; /* argument stack (also save stack) */ PUBLIC truc *argStkPtr, *saveStkPtr; PUBLIC truc *basePtr; PUBLIC word2 *AriBuf, *PrimTab; PUBLIC word2 *AriScratch, *AuxBuf; PUBLIC size_t aribufSize, auxbufSize, scrbufSize; /* unit is sizeof(word2) */ PUBLIC void inialloc (void); PUBLIC int memalloc (int mem); PUBLIC void dealloc (void); PUBLIC void resetarr (void); PUBLIC int initend (void); PUBLIC int tempfree (int flg); PUBLIC int inpack (truc obj, truc pack); PUBLIC char *stringalloc (unsigned int size); PUBLIC unsigned getblocksize (void); PUBLIC size_t new0 (unsigned int size); PUBLIC truc newobj (int flg, unsigned int size, trucptr *ptraddr); PUBLIC truc new0obj (int flg, unsigned int size, trucptr *ptraddr); PUBLIC unsigned obj4size (int type, truc *ptr); PUBLIC void cpy4arr (truc *ptr1, unsigned len, truc *ptr2); /*--------------------------------------------------------*/ typedef struct { byte flag; byte flg2; word2 curbot; word2 blkceil; word2 blkbot; } blkdesc; PRIVATE char *Stringpool; PRIVATE char *Stringsys; PRIVATE size_t symBot, userBot; PRIVATE size_t memBot, memCeil; PRIVATE size_t argstkSize, workstkSize, arrstkSize, blockSize, block0Size; PRIVATE int curblock, noofblocks, auxindex0, maxblocks; PRIVATE blkdesc blockinfo[BLOCKMAX+1]; PRIVATE word4 gccount = 0; PRIVATE truc gcsym, memavsym; PRIVATE void iniconfig (int mem); PRIVATE void inisymtab (void); PRIVATE void iniblock (void); PRIVATE void memstatistics (long slot[4]); PRIVATE void displaymem (long s[]); PRIVATE void gcstatistics (void); #ifdef M_SMALL PRIVATE int memshrink (int nnew, int nold); #endif PRIVATE truc Fmemavail (int argn); PRIVATE void nextblock (unsigned int size); PRIVATE void clearbufs (void); PRIVATE truc Fgc (int argn); PRIVATE int garbcollect (int mode); PRIVATE void prepgc (void); PRIVATE void endgc (void); PRIVATE void mvsymtab (void); PRIVATE void mvargstk (void); PRIVATE void mvarrstk (void); PRIVATE void mvevalstk (void); PRIVATE void moveobj (truc *x); PRIVATE int toupdate (truc *x); PRIVATE int datupdate (int flg); #define FREE 0 #define HALFFULL 1 #define FULL 2 #define RESERVED 4 #define NOAGERL 8 /*------------------------------------------------------------*/ /* ** Dirty trick; throws compile time error if pred is false ** ** #define COMPILE_TIME_ASSERT(pred) switch(0){case 0:case pred:;} ** ** #ifdef ALIGN8 ** COMPILE_TIME_ASSERT(sizeof(wtruc) == 8) ** #endif */ /*------------------------------------------------------------*/ PRIVATE int Align8 = 1; /* ** Align8 = 1: alignment on 8-byte boundaries ** Align8 = 0: alignment on 4-byte boundaries */ /*------------------------------------------------------------*/ PUBLIC void inialloc() { gcsym = newsymsig("gc", sFBINARY, (wtruc)Fgc, s_01); memavsym= newsymsig("memavail", sFBINARY, (wtruc)Fmemavail, s_01); } /*--------------------------------------------------------------*/ PRIVATE void iniconfig(mem) int mem; { int k; long memmax; assert(sizeof(word4) == 4); assert(sizeof(word2) == 2); if (sizeof(wtruc) == 8) { Align8 = 1; } else { Align8 = 0; assert(sizeof(wtruc) == 4); } argstkSize = ARGSTKSIZE; workstkSize = WORKSTKSIZE; arrstkSize = ARRAYSTKSIZE; hashtabSize = HASHTABSIZE; aribufSize = ARIBUFSIZE; blockSize = BLOCKSIZE; block0Size = BLOCK0SIZE; if(mem <= 0) { mem = MEM_DEFAULT; } #ifdef M_LARGE else if(mem < 1000) { block0Size = MED_BLOCK0SIZE; if(mem < 512) mem = 512; } #else else if(mem < 64) mem = 64; #endif #ifdef ATARIST else if(mem >= 1000) { blockSize = BIG_BLOCKSIZE; block0Size = MED_BLOCK0SIZE; } #endif #ifdef DOSorTOS else if(mem >= 200) blockSize = MED_BLOCKSIZE; #endif memmax = blockSize; memmax *= BLOCKMAX; memmax /= 255; if(mem > memmax) mem = memmax; if(mem < 2000) { if(mem < 96) { maxblocks = 2; } else { for(k=3; k= 2000 */ maxblocks = (mem + blockSize/510)/(blockSize/255); if(maxblocks > BLOCKMAX) maxblocks = BLOCKMAX; } } /*--------------------------------------------------------------*/ /* ** allocate memory for Symtab, ** ArgStack, WorkStack, EvalStack, ** Symbol and Memory ** returns total amount of allocated memory (in kilobytes) */ PUBLIC int memalloc(mem) int mem; { int k; unsigned long memallsize; size_t size; void *ptr; stacklimit(); iniconfig(mem); size = sizeof(trucptr) * hashtabSize; memallsize = size; ptr = malloc(size); if(ptr) { Symtab = (trucptr *)ptr; size = sizeof(truc) * argstkSize; memallsize += size; ptr = malloc(size); } if(ptr) { ArgStack = (truc *)ptr; size = sizeof(truc) * workstkSize; memallsize += size; ptr = malloc(size); } if(ptr) { WorkStack = (truc *)ptr; size = sizeof(truc) * arrstkSize; memallsize += size; ptr = malloc(size); } if(ptr) { ArrayStack = (truc *)ptr; ArrayStkCeil = ArrayStack + arrstkSize; size = sizeof(word2)*(aribufSize + PRIMTABSIZE + 16); memallsize += size; ptr = malloc(size); } if(ptr) { AriBuf = (word2 *)ptr; PrimTab = AriBuf + aribufSize + 16; inisymtab(); resetarr(); } else faterr(err_memory); size = sizeof(truc) * block0Size; ptr = malloc(size); #ifdef M_LARGE noofblocks = maxblocks; if(ptr) { memallsize += size; Memory[0] = (truc *)ptr; } else { goto errmem; } size = sizeof(truc)*blockSize*noofblocks; ptr = malloc(size); if(ptr) { memallsize += size; Memory[1] = (truc *)ptr; for(k=2; k<=noofblocks; k++) Memory[k] = Memory[k-1] + blockSize; } else { goto errmem; } #else /* !M_LARGE */ k = 0; while(ptr != NULL) { memallsize += size; Memory[k] = (truc *)ptr; if(++k > maxblocks) break; size = sizeof(truc) * blockSize; ptr = malloc(size); } noofblocks = k-1; #endif /* ?M_LARGE */ ptr = malloc(RESERVE); /* test free memory */ if(ptr != NULL) free(ptr); else { free(Memory[noofblocks]); noofblocks--; memallsize -= size; } if(noofblocks < 2) goto errmem; Symbol = Memory[0]; symBot = 0; Stringpool = (char *)(Symbol + block0Size); iniblock(); return((int)(memallsize >> 10)); errmem: faterr(err_memory); return(0); } /*-------------------------------------------------------------*/ PUBLIC void dealloc() { #ifdef M_LARGE free(Memory[1]); #else int i; for(i=noofblocks; i>=1; i--) if(blockinfo[i].blkbot == 0) free(Memory[i]); #endif free(Symbol); free(AriBuf); free(WorkStack); free(ArrayStack); free(ArgStack); free(Symtab); } /*-------------------------------------------------------------*/ PUBLIC void resetarr() { workStkPtr = WorkStack - 1; evalStkPtr = WorkStack + workstkSize; arrayStkPtr= ArrayStack - 1; argStkPtr = ArgStack - 1; saveStkPtr = ArgStack + argstkSize; basePtr = ArgStack; } /* ------------------------------------------------------- */ PRIVATE void inisymtab() { trucptr *sympt; int i; sympt = Symtab; i = hashtabSize; while(--i >= 0) *sympt++ = NULL; } /*---------------------------------------------------------*/ PRIVATE void iniblock() { int split, m; int i; scrbufSize = (blockSize / sizeof(word2)) * sizeof(truc); #ifdef M_LARGE auxbufSize = (noofblocks*blockSize/2)/sizeof(word2)*sizeof(truc) - scrbufSize; #else /* !M_LARGE */ auxbufSize = scrbufSize; if(noofblocks == 3) auxbufSize /= 2; else if(noofblocks < 3) auxbufSize = 0; #endif /* ?M_LARGE */ m = (noofblocks+1)/2 + 1; split = (noofblocks & 1) && (noofblocks < BLOCKMAX); if(split) { noofblocks++; for(i=noofblocks; i>=m; i--) Memory[i] = Memory[i-1]; } blockinfo[0].flag = noofblocks; for(i=1; i<=noofblocks; i++) { blockinfo[i].flag = (i 0: Gibt die zweite Haelfte der Memory-Bloecke frei ** Mit Argument flg == 0: Allokiert von neuem die freigegebenen ** Memorybloecke ** Rueckgabewert: 1 bei Erfolg, 0 bei Fehler */ PUBLIC int tempfree(flg) int flg; { #ifdef M_SMALL int i, m, res; size_t size; void *ptr; m = (noofblocks/2) + 1; if(blockinfo[m].blkbot > 0) m++; if(flg > 0) { garbcollect(1); if(blockinfo[1].flag == RESERVED) garbcollect(1); /* nun ist zweite Haelfte frei */ for(i=noofblocks; i>=m; i--) free(Memory[i]); } else { size = blockSize * sizeof(truc); for(i=m; i<=noofblocks; i++) { ptr = malloc(size); if(ptr == NULL) { res = memshrink(i-1,noofblocks); if(res == 0) { noofblocks = i-1; return(0); } else break; } Memory[i] = (truc *)ptr; } AriScratch = (word2 *)Memory[noofblocks]; AuxBuf = (word2 *)Memory[noofblocks-1]; } #endif /* M_SMALL */ return(1); } /*---------------------------------------------------------*/ /* ** Reduziert die Anzahl der Memory-Bloecke von nold auf nnew ** Es wird vorausgesetzt, dass die derzeit aktiven Bloecke ** zur ersten Haelfte gehoeren und dass nnew < nold ** Rueckgabewert: 1 bei Erfolg, 0 bei Misserfolg */ #ifdef M_SMALL PRIVATE int memshrink(nnew,nold) int nnew, nold; { int i,m,m1,split; m = (nold/2) + 1; split = (blockinfo[m].blkbot > 0); if(split) nnew--; if(nnew < 2) return(0); else if(nnew == 2) auxbufSize = 0; else if(nnew == 3) auxbufSize /= 2; m1 = nnew/2; for(i=m1; im; i--) Memory[i] = Memory[i-1]; blockinfo[m].blkceil /= 2; blockinfo[m+1].blkbot = blockinfo[m].blkceil; } for(i=nnew; i>m; i--) blockinfo[i].flag = RESERVED; noofblocks = nnew; return(1); } #endif /* M_SMALL */ /*---------------------------------------------------------*/ PUBLIC int inpack(obj,pack) truc obj, pack; { variant v; int sys; v.xx = obj; sys = (v.pp.ww < userBot); if(pack == arisym) return(sys); else if(pack == usersym) return(!sys); else return(0); } /*---------------------------------------------------------*/ PRIVATE void memstatistics(slot) long slot[4]; { int i, flg; unsigned b,c; unsigned long nres = 0, nact = 0, nfree = 0, nsymb; unsigned s = sizeof(truc); for(i=1; i<=noofblocks; i++) { b = blockinfo[i].blkbot; c = blockinfo[i].blkceil; if((flg = blockinfo[i].flag) == RESERVED) { nres += c - b; } else { nact += c - b; if(flg < FULL) { b = (i == curblock ? memBot : blockinfo[i].curbot); nfree += c - b; } } } slot[0] = s * nres; slot[1] = s * nact; slot[2] = s * nfree; nsymb = Stringpool - (char *)(Symbol + symBot); slot[3] = nsymb; } /*---------------------------------------------------------*/ PRIVATE void displaymem(s) long s[]; { int n; long diff; diff = s[1] - s[2]; n = s2form(OutBuf,"~8D Bytes reserved; ~D Bytes active ", intcast(s[0]),intcast(s[1])); s2form(OutBuf+n,"(~D used, ~D free)",intcast(diff),intcast(s[2])); fprintline(tstdout,OutBuf); s1form(OutBuf, "~8D Bytes free for user defined symbols and symbol names", intcast(s[3])); fprintline(tstdout,OutBuf); } /*---------------------------------------------------------*/ PRIVATE void gcstatistics() { fnewline(tstdout); s1form(OutBuf,"total number of garbage collections: ~D", intcast(gccount)); fprintline(tstdout,OutBuf); } /*---------------------------------------------------------*/ PRIVATE truc Fmemavail(argn) int argn; { long s[4]; unsigned f; int verbose; verbose = (argn == 0 || *argStkPtr != zero); memstatistics(s); if(verbose) { gcstatistics(); displaymem(s); } f = s[2] >> 10; /* free kilobytes */ return(mkfixnum(f)); } /*---------------------------------------------------------*/ PUBLIC char *stringalloc(size) unsigned int size; /* unit for size is sizeof(char) */ { if(Stringpool - size <= (char *)(Symbol + symBot)) faterr(err_memory); Stringpool -= size; return(Stringpool); } /*---------------------------------------------------------*/ PUBLIC unsigned getblocksize() { return(blockSize); } /*---------------------------------------------------------*/ PUBLIC size_t new0(size) unsigned int size; /* unit for size is sizeof(truc) */ { size_t loc; loc = symBot; symBot += size; if (Align8 && (symBot & 0x1)) symBot++; if(Stringpool <= (char *)(Symbol + symBot)) faterr(err_memory); return(loc); } /*---------------------------------------------------------*/ PUBLIC truc newobj(flg,size,ptraddr) int flg; unsigned int size; trucptr *ptraddr; { variant v; if(size > memCeil - memBot) { nextblock(size); } v.pp.b0 = flg; v.pp.b1 = curblock; v.pp.ww = memBot; *ptraddr = Memory[curblock] + memBot; memBot += size; return(v.xx); } /*---------------------------------------------------------*/ /* ** allocation from memory block 0 ** (for symbols, not moved during garbage collection) */ PUBLIC truc new0obj(flg,size,ptraddr) int flg; unsigned int size; /* unit for size is sizeof(truc) */ trucptr *ptraddr; { variant v; size_t loc = new0(size); v.pp.b0 = flg; v.pp.b1 = 0; v.pp.ww = loc; *ptraddr = Symbol + loc; return(v.xx); } /*---------------------------------------------------------*/ PRIVATE void nextblock(size) unsigned int size; { int i,k; int collected = 0; blockinfo[curblock].curbot = memBot; blockinfo[curblock].flag = (memCeil - memBot >= NOAGERL ? HALFFULL : FULL); if(size > blockSize) { reset(err_2large); } nochmal: k = curblock; for(i=1; i<=noofblocks; i++) { if(++k > noofblocks) k = 1; if((blockinfo[k].flag <= HALFFULL) && (size <= blockinfo[k].blkceil - blockinfo[k].curbot)) { memBot = blockinfo[k].curbot; memCeil = blockinfo[k].blkceil; curblock = k; return; } } if(!collected && garbcollect(1)) { collected = 1; goto nochmal; } clearbufs(); if(garbcollect(0)) reset(err_memev); else faterr(err_garb); } /*------------------------------------------------------------*/ PRIVATE void clearbufs() { *res3Ptr = zero; *res2Ptr = zero; *res1Ptr = zero; *brkbindPtr = zero; } /*------------------------------------------------------------*/ PRIVATE truc Fgc(argn) int argn; { garbcollect(1); return Fmemavail(argn); } /*------------------------------------------------------------*/ PRIVATE int garbcollect(mode) int mode; /* mode = 0: emergency collection */ { static int merk = 0; gccount++; if(merk++) { merk = 0; return(0); } prepgc(); mvsymtab(); if(mode > 0) { mvargstk(); mvevalstk(); mvarrstk(); } endgc(); --merk; return(1); } /*------------------------------------------------------------*/ PRIVATE void prepgc() { int i, first = 1; for(i=1; i<=noofblocks; i++) { blockinfo[i].curbot = blockinfo[i].blkbot; if(blockinfo[i].flag == RESERVED) { blockinfo[i].flag = FREE; if(first) { curblock = i; memBot = blockinfo[i].curbot; memCeil = blockinfo[i].blkceil; first = 0; } } else blockinfo[i].flag = RESERVED; } } /*------------------------------------------------------------*/ PRIVATE void endgc() { int scratchind, auxind; blockinfo[curblock].curbot = memBot; if(blockinfo[1].flag == RESERVED) { scratchind = 1; auxind = 2; } else { scratchind = noofblocks; auxind = auxindex0; } AriScratch = (word2 *)Memory[scratchind]; AuxBuf = (word2 *)Memory[auxind]; } /*------------------------------------------------------------*/ PRIVATE void mvsymtab() { int n, flg; truc *x; *res3Ptr = zero; n = 0; while((x = nextsymptr(n++)) != NULL) { flg = *FLAGPTR(x); if(flg & sGCMOVEBIND) moveobj(SYMBINDPTR(x)); } } /*------------------------------------------------------------*/ PRIVATE void mvargstk() { truc *ptr; ptr = ArgStack - 1; while(++ptr <= argStkPtr) moveobj(ptr); } /*------------------------------------------------------------*/ PRIVATE void mvarrstk() { truc *ptr; ptr = ArrayStack - 1; while(++ptr <= arrayStkPtr) moveobj(ptr); } /*------------------------------------------------------------*/ PRIVATE void mvevalstk() { truc *ptr; ptr = WorkStack - 1; while(++ptr <= workStkPtr) moveobj(ptr); ptr = WorkStack + workstkSize; while(--ptr >= evalStkPtr) moveobj(ptr); } /*------------------------------------------------------------*/ PRIVATE void moveobj(x) truc *x; { int flg; unsigned int len; truc *ptr, *ptr2; nochmal: flg = toupdate(x); if(!flg) return; ptr = TAddress(x); if(*FLAGPTR(ptr) == GCMARK) { /* update *x */ *x = *ptr; *FLAGPTR(x) = flg; return; } len = obj4size(flg,ptr); if(len == 0) /* this case should not happen */ return; *x = newobj(flg,len,&ptr2); cpy4arr(ptr,len,ptr2); *ptr = *x; /* put forwarding address */ *FLAGPTR(ptr) = GCMARK; if(datupdate(flg) && (len >= 2)) { while(--len > 1) /* first element always fixed */ moveobj(++ptr2); /*** tail recursion elimination *******/ x = ptr2 + 1; goto nochmal; } } /*------------------------------------------------------------*/ /* ** returns 0, if *x needs no update; else returns flag of *x */ PRIVATE int toupdate(x) truc *x; { int flg, seg; flg = *FLAGPTR(x); if(flg & FIXMASK) return(0); seg = *SEGPTR(x); if(seg == 0 || blockinfo[seg].flag != RESERVED) return(0); else { return(flg); } } /*------------------------------------------------------------*/ /* ** returns 0, if data of object are fixed, else returns 1 */ PRIVATE int datupdate(flg) int flg; { if(flg == fSTREAM) return(0); else if(flg <= fVECTOR) return(1); else return(0); } /*------------------------------------------------------------*/ /* ** return size of objects (unit is sizeof(truc)=4) ** which are not fixed during garbage collection */ PUBLIC unsigned obj4size(type,ptr) int type; truc *ptr; { unsigned int len; switch(type) { case fBIGNUM: case fGF2NINT: len = ((struct bigcell *)ptr)->len; return(SIZEOFBIG(len)); case fSTRING: case fBYTESTRING: len = ((struct strcell *)ptr)->len; return(SIZEOFSTRING(len)); case fSTREAM: return(SIZEOFSTREAM); case fVECTOR: len = ((struct vector *)ptr)->len; return(SIZEOFVECTOR(len)); case fPOINTER: case fRECORD: len = ((struct record *)ptr)->len; return(SIZEOFRECORD(len)); case fSPECIAL1: case fBUILTIN1: return(SIZEOFOPNODE(1)); case fSPECIAL2: case fBUILTIN2: return(SIZEOFOPNODE(2)); case fTUPLE: case fWHILEXPR: case fIFEXPR: case fFOREXPR: case fCOMPEXPR: len = ((struct compnode *)ptr)->len; return(SIZEOFCOMP(len)); case fSPECIALn: case fBUILTINn: case fFUNCALL: len = *ARGCPTR(ptr); return(SIZEOFFUNODE(len)); case fFUNDEF: return(SIZEOFFUNDEF); case fSTACK: return(SIZEOFSTACK); default: if(type >= fFLTOBJ) { len = fltprec(type); return(SIZEOFFLOAT(len)); } else { error(gcsym,err_case,mkfixnum(type)); return(0); } } } /*------------------------------------------------------------*/ /* ** kopiert das word4-Array (ptr1,len) nach ptr2 */ PUBLIC void cpy4arr(ptr1,len,ptr2) truc *ptr1, *ptr2; unsigned int len; { while(len--) *ptr2++ = *ptr1++; } /************************************************************************/ aribas165b/src/analysis.c0000644000076600000240000007513414660570650014367 0ustar ottostaff/****************************************************************/ /* file analysis.c ARIBAS interpreter for Arithmetic Copyright (C) 1996 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** analysis.c ** transcendental functions ** ** date of last change ** 1995-02-21 ** 1997-04-14: changed inipi ** 2010-01-23: bugfix in sin0 and cos0 with floatprec > 2048 */ #include "common.h" PUBLIC void inianalys (void); PUBLIC int lognum (int prec, numdata *nptr, word2 *hilf); PUBLIC int expnum (int prec, numdata *nptr, word2 *hilf); /*--------------------------------------------------------*/ PRIVATE truc expsym, logsym, sqrtsym, sinsym, cossym; PRIVATE truc tansym, atansym, atan2sym, asinsym, acossym; PRIVATE truc pisym; PRIVATE truc inipi (int prec); PRIVATE int Gget1flt (truc symb, numdata *nptr); PRIVATE truc Fsqrt (void); PRIVATE truc Fexp (void); PRIVATE truc Flog (void); PRIVATE truc Fsin (void); PRIVATE truc Fcos (void); PRIVATE truc Ftan (void); PRIVATE truc Gtrig (truc symb); PRIVATE truc Fatan (void); PRIVATE truc Fatan2 (void); PRIVATE truc Fasin (void); PRIVATE truc Facos (void); PRIVATE truc Garcus (truc symb); PRIVATE int atannum (int prec, numdata *nptr1, numdata *nptr2, word2 *hilf); PRIVATE int atanprep (int prec, numdata *nptr1, numdata *nptr2, word2 *x, int *segptr); PRIVATE int trignum (int prec, numdata *nptr, word2 *hilf, truc symb); PRIVATE int expovfl (numdata *nptr, word2 *hilf); PRIVATE long redmod (int prec, numdata *nptr, word2 *modul, int modlen, word2 *hilf); PRIVATE int exp0 (int prec, word2 *x, int n, word2 *z, word2 *hilf); PRIVATE int exp0aux (word2 *x, int n, unsigned a, int k, word2 *temp); PRIVATE int exp1aux (word2 *x, int n, unsigned a, int k, word2 *temp); PRIVATE int sin0 (int prec, word2 *x, int n, word2 *z, word2 *hilf); PRIVATE int cos0 (int prec, word2 *x, int n, word2 *z, word2 *hilf); PRIVATE int log0 (int prec, word2 *x, int n, word2 *z, word2 *hilf); PRIVATE unsigned log1_16 (unsigned x); PRIVATE int atan0 (int prec, word2 *x, int n, word2 *z, word2 *hilf); PRIVATE int curfltprec; PRIVATE word2 LOG2DAT[] = /* log(2) */ #ifdef FPREC_HIGH {322, 0x154C, 0xB783, 0x64F1, 0xEC3F, 0x53DA, 0x501E, 0xF281, 0x9316, 0xDB4A, 0xF949, 0x56C9, 0xC921, 0xBE2E, 0x341C, 0x94F0, 0xF58D, 0xCA8, 0x4A00, 0xD287, 0x3D7, 0x554B, 0xE00C, 0x5497, 0x75DF, 0xFB0C, 0x2D06, 0xECA4, 0x850, 0xEE6E, 0xEC2F, 0xEF22, 0x5B8A, 0x364F, 0x3C9F, 0x78B6, 0x39CE, 0x897A, 0x8438, 0x1E23, 0x3316, 0x52AB, 0xC60C, 0xA6C4, 0x1A63, 0x62B, 0xEDD, 0xE8F7, 0x449F, 0x3EA8, 0xC51C, 0x26FA, 0xA415, 0x6425, 0x84E0, 0xF958, 0x767D, 0xC5E5, 0x23FA, 0x8A0E, 0xB31D, 0xC0B1, 0xBD0D, 0x3A49, 0x6AB0, 0x85DB, 0xADD8, 0xC8DA, 0xB4AF, 0x175E, 0x374E, 0xA892, 0xFFF3, 0xF07A, 0x891E, 0xDEA, 0x2625, 0x8F68, 0x339D, 0x9C38, 0x72F1, 0xCECB, 0x45AE, 0xAC9F, 0x7CEB, 0x5F6F, 0x15C0, 0xE761, 0x2096, 0x6C47, 0x9D42, 0xFBBD, 0xD18B, 0x972C, 0xC724, 0xBD67, 0x11BB, 0xAB1, 0x38B9, 0xA0C2, 0x26FD, 0x4738, 0xAEBD, 0xD24A, 0x696D, 0x61C1, 0xD5E3, 0x2413, 0xC29, 0x156E, 0x7487, 0xDC4E, 0x4460, 0x9518, 0x646A, 0x901E, 0x2658, 0xD762, 0x3958, 0xD737, 0xCE2, 0xEF2F, 0x207C, 0xC4E9, 0xB61C, 0x2AC5, 0x7D05, 0xBEBA, 0x9BA2, 0x5733, 0x1A0C, 0x839, 0xE499, 0x60, 0x302, 0x6AF5, 0x6319, 0x6213, 0xD2F9, 0x3D0B, 0x28D5, 0x5C1, 0x86B9, 0xCEE8, 0x2B20, 0x36E0, 0x49F2, 0xF3D9, 0x16FA, 0xBBB, 0x2109, 0xC994, 0x83ED, 0x4221, 0xD3C5, 0x8C66, 0x22B8, 0x5E92, 0xA3CF, 0x6B1C, 0xFD44, 0x61AF, 0xB982, 0x9538, 0x5C1F, 0x268A, 0x755, 0xFBCF, 0x5177, 0x8D6F, 0x4EF9, 0x228A, 0x93D1, 0xA172, 0xDC8E, 0x731C, 0x2554, 0x44A0, 0x889B, 0x30AF, 0xE6D3, 0x96D4, 0x9834, 0x8F96, 0xB6C6, 0x5570, 0x73EE, 0x1AE2, 0xA195, 0x7598, 0x853D, 0xB365, 0x2DB3, 0x4D16, 0xC18B, 0x5064, 0xB518, 0x5F50, 0xB31B, 0x1B2D, 0x735D, 0x78F, 0x6CB1, 0x6C60, 0x3CDB, 0xAE31, 0x7B9D, 0xB1E1, 0x5179, 0x955D, 0xD2C, 0x1735, 0xA54, 0xC48, 0x7AA3, 0x5CFE, 0xB601, 0x74D, 0x8E82, 0x5E14, 0x7F8A, 0x6A9C, 0xA337, 0x3564, 0x9B33, 0x2566, 0x95D, 0xD1D6, 0x1E0B, 0x4C1A, 0x514C, 0x9393, 0x4E65, 0xCCCC, 0xCD33, 0xB479, 0xE732, 0xC943, 0x90E5, 0xDB89, 0x775, 0x1746, 0xB396, 0x1400, 0x23DE, 0x7D2E, 0xFA15, 0xFC1E, 0x9D6D, 0xEE56, 0x51A2, 0x8FE5, 0x30F8, 0x610D, 0xFB90, 0xFB5B, 0xCA11, #else {66, #endif 0x7F4, 0xD5C6, 0xF3F, 0x97C5, 0xDA2D, 0xE3A2, 0x2F20, 0xA187, 0x655F, 0x3248, 0x3830, 0xA6BD, 0xF5DF, 0x48CA, 0x9D65, 0x87B1, 0x72CE, 0xF74B, 0x7657, 0xA0EC, 0x256F, 0x603B, 0xB136, 0x9BC3, 0xB9EA, 0x387E, 0x317C, 0xDA11, 0x1ACB, 0xE8C5, 0x224A, 0xCA16, 0x3E96, 0xB825, 0x1169, 0x3B29, 0x2757, 0x2144, 0xC138, 0xAE35, 0xED2E, 0x1B10, 0x4AFA, 0x52FB, 0x5595, 0xAC98, 0x6DEB, 0x7620, 0xE7B8, 0xFA2B, 0x8BAA, 0x175B, 0x8A0D, 0xB62D, 0x7298, 0x4326, 0x40F3, 0xF6AF, 0x3F2, 0xB398, 0xC9E3, 0x79AB, 0xD1CF, 0x17F7, 0xB172}; PRIVATE word2 PI4THDAT[] = /* pi/4 */ #ifdef FPREC_HIGH {322, 0x23A9, 0xE8F3, 0xBEC7, 0xC97F, 0x59E7, 0x1C9E, 0x900B, 0x4031, 0xB5A8, 0xC82, 0x4698, 0x702F, 0xD55E, 0xFEF6, 0x6E74, 0xD7CE, 0xF482, 0x1D03, 0xD172, 0xEA15, 0xF032, 0x92EC, 0xC64B, 0xCA01, 0x5983, 0xD2BF, 0x378C, 0xF401, 0x6FB8, 0xAF42, 0x2BD7, 0x5151, 0x3320, 0x254B, 0xE6CC, 0x1447, 0xDB7F, 0xBB1B, 0xCED4, 0x6CBA, 0x44CE, 0x14ED, 0xCF9B, 0xDBEB, 0xDA3E, 0x8918, 0x865A, 0x27B0, 0x1797, 0xD831, 0x9027, 0x53ED, 0xB06A, 0x1AE, 0x4130, 0x382F, 0xE5DB, 0x530E, 0xAD9E, 0x9406, 0xF8FF, 0x37BD, 0x3DBA, 0x1E76, 0xC975, 0x46DE, 0x6026, 0xDCB2, 0xC1D4, 0x7026, 0xD27C, 0xFAB4, 0x36C3, 0x8492, 0x3402, 0x35C9, 0x4DF4, 0xC08F, 0x90A6, 0xB7DC, 0x86FF, 0xDDC1, 0x8D8F, 0xEA98, 0x93B4, 0x5AA9, 0xD5B0, 0x9127, 0xD006, 0x481C, 0x2170, 0xDD76, 0xB81B, 0xD7AF, 0xCEE2, 0x2970, 0x1F61, 0xE7ED, 0x515B, 0xA186, 0x233B, 0xC3A2, 0xA090, 0x964F, 0x99B2, 0xC05D, 0x4E6B, 0x5947, 0x287C, 0xCAA6, 0x1FBE, 0xFC14, 0x2E8E, 0x8EF9, 0x4DE, 0xC2DB, 0xDBBB, 0x4CE8, 0x2AD4, 0xE9CA, 0x2583, 0xBDA, 0xB615, 0x6834, 0x1A94, 0xE23C, 0x6AF4, 0x2718, 0x99C3, 0x5B26, 0xBDBA, 0x9A10, 0x8871, 0xE6D7, 0xA787, 0x3C12, 0x1A72, 0x801, 0xA921, 0xD120, 0x4B82, 0x108E, 0xE0FD, 0x5BFC, 0x43DB, 0xAB31, 0x74E5, 0x4FA0, 0x8E2, 0x46E2, 0xBAD9, 0x88C0, 0x7709, 0x5D6C, 0x7A61, 0x1757, 0xBBE1, 0x200C, 0x177B, 0x2B18, 0x521F, 0x6A64, 0x3EC8, 0x273, 0xD876, 0x864, 0xD98A, 0xFA06, 0xF12F, 0xEE6B, 0x1AD2, 0xD226, 0xCEE3, 0x619D, 0x4A25, 0x94E0, 0x1E8C, 0x33D7, 0xDB09, 0xAE8C, 0xABF5, 0xE4C7, 0xA6E1, 0xF85, 0xB397, 0xC7D, 0x5D06, 0x7157, 0x8AEA, 0xEF0A, 0x58DB, 0x8504, 0xECFB, 0xBA64, 0xDF1C, 0x21AB, 0xA855, 0x7A33, 0x450, 0x170D, 0xAD33, 0xC42D, 0x8AAA, 0x8E5A, 0x1572, 0x510, 0x98FA, 0x2618, 0x15D2, 0x6AE5, 0xEA95, 0x497C, 0x3995, 0x1718, 0x9558, 0xCBF6, 0xDE2B, 0x52C9, 0x6F4C, 0x5DF0, 0xB5C5, 0xA28F, 0xEC07, 0x83A2, 0x9B27, 0x8603, 0x180E, 0x772C, 0xE39E, 0xCE3B, 0x2E36, 0x5E46, 0x3290, 0x217C, 0xCA18, 0x6C08, 0xF174, 0x9804, 0x4ABC, 0x354E, 0x670C, 0x966D, 0x7096, 0x2907, 0x9ED5, 0x52BB, 0x2085, 0xF356, 0x1C62, 0xAD96, 0xDCA3, 0x5D23, 0x8365, 0xCF5F, 0xFD24, 0x3FA8, #else {66, #endif 0x6916, 0xD39A, 0x1C55, 0x4836, 0x98DA, 0xBF05, 0xA163, 0x7CB8, 0xC200, 0x5B3D, 0xECE4, 0x6651, 0x4928, 0x1FE6, 0x7C4B, 0x2411, 0xAE9F, 0x9FA5, 0x5A89, 0x6BFB, 0xEE38, 0xB7ED, 0xF406, 0x5CB6, 0xBFF, 0xED6B, 0xA637, 0x42E9, 0xF44C, 0x7EC6, 0x625E, 0xB576, 0xE485, 0xC245, 0x6D51, 0x356D, 0x4FE1, 0x1437, 0xF25F, 0xA6D, 0x302B, 0x431B, 0xCD3A, 0x19B3, 0xEF95, 0x4DD, 0x8E34, 0x879, 0x514A, 0x9B22, 0x3B13, 0xBEA6, 0x20B, 0xCC74, 0x8A67, 0x4E08, 0x2902, 0x1CD1, 0x80DC, 0x628B, 0xC4C6, 0xC234, 0x2168, 0xDAA2, 0xC90F}; PRIVATE word2 ATAN4DAT[] = /* atan(1/4) */ #ifdef FPREC_HIGH {322, 0x6B3F, 0x5870, 0xADCF, 0xE549, 0x1C7F, 0x82B2, 0x9F6F, 0x5450, 0xE8F, 0xB2E1, 0x95F5, 0x9CE5, 0x998F, 0x64AE, 0x9F2F, 0xDE06, 0xF67, 0xF39, 0x111B, 0x3858, 0x25DF, 0x7580, 0x7910, 0xC3A6, 0x5FC3, 0xD1A8, 0xD87A, 0xE0C5, 0x559D, 0xDDFE, 0x68B1, 0x81C0, 0x1970, 0x7B17, 0xE38E, 0x6D8A, 0xCB0F, 0x5873, 0x6156, 0x89FD, 0xD3FF, 0x5798, 0xD222, 0x62A3, 0x2B89, 0x5A2C, 0x260F, 0xCCE9, 0x293D, 0xE516, 0x4EFB, 0xBD90, 0x4872, 0x20F, 0x4EE8, 0xE6DA, 0x95AF, 0x4E41, 0x3EB, 0xACB3, 0x4BB, 0xFA89, 0x7C7B, 0xE015, 0xB5E, 0xD3B4, 0xE52, 0x8AAD, 0x23A1, 0xC362, 0x18B1, 0x55A6, 0x43E0, 0xD662, 0x5797, 0x3973, 0x13D8, 0x973E, 0xF08F, 0x3D2F, 0x90F, 0x24A3, 0x1BEF, 0xE4D5, 0xBD6F, 0x59FF, 0x62B7, 0xDBB9, 0x1D86, 0xBB9E, 0xAFC2, 0x44FD, 0xA3B, 0x2F5C, 0x6A0E, 0x683, 0x9A47, 0xFCE5, 0xA135, 0x4C26, 0x53DD, 0x2C34, 0x24E0, 0xD837, 0xB3AE, 0xBC2B, 0xD2D4, 0x734B, 0x1532, 0x7380, 0x5C33, 0x575, 0xC233, 0x2399, 0xBAE6, 0x7055, 0xF5A3, 0x4C75, 0x25A3, 0x2990, 0x818C, 0xAD7F, 0x8904, 0x4750, 0xFF60, 0x5C39, 0xFAA1, 0x9C67, 0xF168, 0xE82D, 0x6B10, 0xD0C5, 0xD5B4, 0x9B3A, 0x9454, 0x29C8, 0x4BE0, 0x81CB, 0x4EAB, 0xEAF8, 0x579A, 0x338B, 0x4F0D, 0x3013, 0xDBAF, 0xD9A3, 0xF5E0, 0x6F27, 0x5EDE, 0xB593, 0xCBCE, 0x3DD7, 0x5BCE, 0x2D5D, 0xA47C, 0x9F21, 0x2301, 0xCBE5, 0x11E3, 0x9164, 0xCBDC, 0x79E8, 0x4BA8, 0xCEF1, 0x17C3, 0x56EC, 0x494, 0x7880, 0x80E9, 0x31E6, 0x23C7, 0xEA04, 0xE55F, 0xFA48, 0x7482, 0xE6EF, 0x8AEF, 0x170F, 0xAB2D, 0xC9E8, 0x9A8F, 0x6030, 0x5040, 0xC199, 0xF2AD, 0x8FA1, 0x8187, 0xF447, 0x7EED, 0x6403, 0xC38D, 0xC50D, 0x32FA, 0xEF27, 0x2E51, 0xCE00, 0x3E5A, 0x8682, 0x2519, 0xEA4, 0x2861, 0x3E51, 0xB4BB, 0x6267, 0xF41, 0x3D03, 0xFA02, 0x9927, 0x4748, 0x5F53, 0x2703, 0x4487, 0xBCA2, 0x63CE, 0x7F56, 0x950C, 0x492E, 0x1875, 0xEEBA, 0xE60, 0xDA37, 0x9A95, 0x1906, 0x77BF, 0xE0DF, 0xB528, 0xFCFC, 0xA1D, 0xDBFB, 0x2714, 0xFB05, 0x8AA1, 0x6928, 0xB682, 0x65A9, 0x50C7, 0x38B1, 0x4DD3, 0x1BED, 0x4652, 0xD4F7, 0xE21E, 0xA8AB, 0xE37, 0x8EC9, 0xAEA6, 0x1541, 0x16BE, 0x3E03, 0xA59D, 0x5E8, 0x5574, 0x77B4, 0xA43E, 0x3638, 0x2903, #else {66, #endif 0x6F3D, 0xC10E, 0xF52C, 0x8AB6, 0x7616, 0xFD3E, 0x172D, 0x2301, 0x3520, 0x463F, 0x9382, 0xA65, 0xC31B, 0x1204, 0xD9EA, 0x1DE7, 0x6EE5, 0xF2CB, 0xCF96, 0x738F, 0xF848, 0x9C81, 0xEB38, 0x48D5, 0x234, 0xF724, 0x5756, 0x7231, 0xFDA2, 0xA695, 0xF8FC, 0xADD0, 0x67A2, 0x60DE, 0xC0E6, 0x70EA, 0x83D0, 0x93E6, 0xC1C7, 0xF089, 0x8F0A, 0xC68F, 0xE960, 0xA316, 0xC16F, 0x5D94, 0x9A39, 0x4945, 0x64AE, 0x69D9, 0x2512, 0x9D9F, 0xDE8E, 0xE0DA, 0xE22C, 0xEA40, 0x6A9F, 0x85F9, 0x7DE8, 0xE7BD, 0x5B71, 0xBAC5, 0x5901, 0xEBF2, 0x3EB6}; #define LOG2(prec) LOG2DAT + (*LOG2DAT - (prec)) #define PI4TH(prec) PI4THDAT + (*PI4THDAT - (prec)) #define ATAN4(prec) ATAN4DAT + (*ATAN4DAT - (prec)) /*----------------------------------------------------------------*/ PUBLIC void inianalys() { expsym = newsymsig("exp", sFBINARY, (wtruc)Fexp, s_rr); sqrtsym = newsymsig("sqrt", sFBINARY, (wtruc)Fsqrt,s_rr); sinsym = newsymsig("sin", sFBINARY, (wtruc)Fsin, s_rr); cossym = newsymsig("cos", sFBINARY, (wtruc)Fcos, s_rr); tansym = newsymsig("tan", sFBINARY, (wtruc)Ftan, s_rr); logsym = newsymsig("log", sFBINARY, (wtruc)Flog, s_rr); atansym = newsymsig("arctan",sFBINARY, (wtruc)Fatan,s_rr); atan2sym = newsymsig("arctan2",sFBINARY, (wtruc)Fatan2,s_rrr); asinsym = newsymsig("arcsin",sFBINARY, (wtruc)Fasin,s_rr); acossym = newsymsig("arccos",sFBINARY, (wtruc)Facos,s_rr); pisym = newsym("pi", sSCONSTANT, inipi(FltPrec[MaxFltLevel])); } /*------------------------------------------------------------------*/ PRIVATE truc inipi(prec) int prec; { numdata acc; acc.sign = 0; acc.digits = PI4TH(prec); acc.len = prec; acc.expo = -(prec<<4) + 2; /* (pi/4)*4 */ return(mk0float(&acc)); } /*----------------------------------------------------------------*/ /* ** Setzt nptr->digits = AriBuf ** und holt float aus argStkPtr nach nptr; ** setzt curfltprec und gibt prec = curfltprec + 1 zurueck. ** Im Fehlerfall Rueckgabewert = ERROR */ PRIVATE int Gget1flt(symb,nptr) truc symb; numdata *nptr; { int prec, type; type = chknum(symb,argStkPtr); if(type == aERROR) return(aERROR); curfltprec = deffltprec(); prec = curfltprec + 1; nptr->digits = AriBuf; getnumtrunc(prec,argStkPtr,nptr); return(prec); } /*----------------------------------------------------------------*/ PRIVATE truc Fsqrt() { numdata acc; word2 *hilf, *x; long m; int prec; int sh, len, rlen; prec = Gget1flt(sqrtsym,&acc); if(prec == aERROR) return(brkerr()); if(acc.sign) { error(sqrtsym,err_p0num,*argStkPtr); return(brkerr()); } if((len = acc.len)) { sh = (curfltprec << 5) + 8; sh -= bitlen(*(AriBuf + len - 1)) + ((len - 1) << 4) - 1; len = shiftarr(AriBuf,len,sh); m = acc.expo - sh; if(m & 1) { len = shlarr(AriBuf,len,1); m -= 1; } x = AriScratch; hilf = AriScratch + aribufSize; cpyarr(AriBuf,len,x); acc.len = bigsqrt(x,len,AriBuf,&rlen,hilf); acc.expo = (m >> 1); } return(mkfloat(curfltprec,&acc)); } /*----------------------------------------------------------------*/ PRIVATE truc Fexp() { numdata acc; int prec; int ret; prec = Gget1flt(expsym,&acc); if(prec == aERROR) return(brkerr()); ret = expnum(prec,&acc,AriScratch); if(ret == aERROR) { error(expsym,err_ovfl,voidsym); return(brkerr()); } return(mkfloat(curfltprec,&acc)); } /*----------------------------------------------------------------*/ PRIVATE truc Flog() { numdata acc; int prec; int ret; prec = Gget1flt(logsym,&acc); if(prec == aERROR) return(brkerr()); ret = lognum(prec,&acc,AriScratch); if(ret == aERROR) { error(logsym,err_pnum,*argStkPtr); return(brkerr()); } return(mkfloat(curfltprec,&acc)); } /*----------------------------------------------------------------*/ PRIVATE truc Fsin() { return(Gtrig(sinsym)); } /*----------------------------------------------------------------*/ PRIVATE truc Fcos() { return(Gtrig(cossym)); } /*----------------------------------------------------------------*/ PRIVATE truc Ftan() { return(Gtrig(tansym)); } /*----------------------------------------------------------------*/ PRIVATE truc Gtrig(symb) truc symb; { numdata acc, acc2; int prec; int ret; prec = Gget1flt(symb,&acc); if(prec == aERROR) return(brkerr()); if(symb == sinsym || symb == cossym) ret = trignum(prec,&acc,AriScratch,symb); else { /* symb == tansym */ acc2.digits = AriScratch + aribufSize; cpynumdat(&acc,&acc2); ret = trignum(prec,&acc2,AriScratch,cossym); ret = trignum(prec,&acc,AriScratch,sinsym); ret = divtrunc(prec,&acc,&acc2,AriScratch); } if(ret == aERROR) { error(symb,err_ovfl,voidsym); return(brkerr()); } return(mkfloat(curfltprec,&acc)); } /*----------------------------------------------------------------*/ PRIVATE truc Fatan() { truc res; ARGpush(constone); res = Fatan2(); ARGpop(); return(res); } /*----------------------------------------------------------------*/ PRIVATE truc Fatan2() { numdata acc1, acc2; word2 *hilf; int type, prec; int ret; type = chknums(atan2sym,argStkPtr-1,2); if(type == aERROR) return(brkerr()); acc1.digits = AriBuf; acc2.digits = AriScratch; hilf = AriScratch + aribufSize; curfltprec = fltprec(type); prec = curfltprec + 1; getnumtrunc(prec,argStkPtr-1,&acc1); getnumtrunc(prec,argStkPtr,&acc2); ret = atannum(prec,&acc1,&acc2,hilf); if(ret == aERROR) { error(atansym,err_ovfl,voidsym); return(brkerr()); } return(mkfloat(curfltprec,&acc1)); } /*----------------------------------------------------------------*/ PRIVATE truc Fasin() { return(Garcus(asinsym)); } /*----------------------------------------------------------------*/ PRIVATE truc Facos() { return(Garcus(acossym)); } /*----------------------------------------------------------------*/ PRIVATE truc Garcus(symb) truc symb; { numdata acc1, acc2; word2 *x, *y, *z, *hilf; int prec, prec2, ret, cmp, rlen; int n, m; prec = Gget1flt(symb,&acc1); if(prec == aERROR) return(brkerr()); prec2 = prec + prec; x = acc1.digits; acc2.digits = y = AriScratch; z = AriScratch + aribufSize; hilf = z + prec2 + 2; setarr(z,prec2,0); z[prec2] = 1; n = alignfix(prec,&acc1); if(n == aERROR || (cmp = cmparr(x,n,z+prec,prec+1)) > 0) { error(symb,err_range,*argStkPtr); return(brkerr()); } if(cmp == 0) /* abs(x) = 1 */ int2numdat(0,&acc2); else if(n == 0) /* x = 0 */ int2numdat(1,&acc2); else { m = multbig(x,n,x,n,y,hilf); m = sub1arr(y,m,z,prec2+1); /* z = 1 - x*x */ m = bigsqrt(y,m,z,&rlen,hilf); cpyarr(z,m,y); /* y = sqrt(1 - x*x) */ acc2.len = m; acc2.sign = 0; acc2.expo = -(prec<<4); } if(symb == asinsym) ret = atannum(prec,&acc1,&acc2,hilf); else { ret = atannum(prec,&acc2,&acc1,hilf); cpynumdat(&acc2,&acc1); } if(ret == aERROR) { error(symb,err_ovfl,voidsym); return(brkerr()); } return(mkfloat(curfltprec,&acc1)); } /*----------------------------------------------------------------*/ /* ** Ersetzt nptr1 durch den Arcus-Tangens des Quotienten ** aus nptr1 und nptr2 */ PRIVATE int atannum(prec,nptr1,nptr2,hilf) int prec; numdata *nptr1, *nptr2; word2 *hilf; { word2 *x, *z; int seg, s, sign, m, n; x = hilf; hilf += prec << 1; z = nptr1->digits; n = atanprep(prec,nptr1,nptr2,x,&seg); if(n < 0) return(n); /* aERROR */ m = atan0(prec,x,n,z,hilf); nptr1->sign = sign = (seg < 0 ? MINUSBYTE : 0); if(sign) seg = -seg - 2; s = ((seg + 2) >> 1) & 0xFFFE; if(s) { n = multarr(PI4TH(prec),prec,s,hilf); if(seg & 2) { m = sub1arr(z,m,hilf,n); } else m = addarr(z,m,hilf,n); } nptr1->len = m; nptr1->expo = -(prec << 4); return(m); } /*----------------------------------------------------------------*/ /* ** Falls Zahl nptr2 groesser als Zahl in nptr1, ** wird nptr1 durch nptr2 dividiert, ** andernfalls wird nptr2 durch nptr1 dividiert. ** Ist len der Rueckgabewert so erhaelt man ** Ergebnis = (x,len) * (2**16)**(-prec) ** Platz x muss genuegend lang sein ** Arbeitet destruktiv auf nptr1 und nptr2 !!! */ PRIVATE int atanprep(prec,nptr1,nptr2,x,segp) int prec; numdata *nptr1, *nptr2; word2 *x; int *segp; { numdata *temp; long diff, sh; int n, m, sign1, sign2; int cmp; sign1 = nptr1->sign; sign2 = nptr2->sign; n = alignfloat(prec+1,nptr1); m = alignfloat(prec+1,nptr2); if(!n) { if(!m) return(aERROR); else { *segp = (sign2 ? 8 : 0); return(0); } } else if(!m) { *segp = (sign1 ? -4 : 4); return(0); } if(!sign1) *segp = (sign2 ? 4 : 0); else *segp = (sign2 ? -8 : -4); if(sign1 != sign2) { temp = nptr1; nptr1 = nptr2; nptr2 = temp; } diff = nptr1->expo - nptr2->expo; if(diff == 0) cmp = (nptr1->digits[prec] > nptr2->digits[prec]); else cmp = (diff > 0); if(cmp) { /* nptr1 groesser */ *segp += 2; temp = nptr1; nptr1 = nptr2; nptr2 = temp; } n = divtrunc(prec,nptr1,nptr2,x); cpyarr(nptr1->digits,n,x); sh = (prec << 4) + nptr1->expo; n = lshiftarr(x,n,sh); return(n); } /*----------------------------------------------------------------*/ PRIVATE int trignum(prec,nptr,hilf,symb) int prec; numdata *nptr; word2 *hilf; truc symb; { word2 *x; int m, n; m = redmod(prec,nptr,PI4TH(prec),prec,hilf); if(m & 1) { nptr->len = sub1arr(nptr->digits,nptr->len,PI4TH(prec),prec); } x = hilf; hilf += prec; n = nptr->len; cpyarr(nptr->digits,n,x); if(symb == cossym) m += 2; if((m+1) & 2) nptr->len = cos0(prec,x,n,nptr->digits,hilf); else nptr->len = sin0(prec,x,n,nptr->digits,hilf); nptr->sign = (m & 4 ? MINUSBYTE : 0); nptr->expo = -(prec << 4); return(nptr->len); } /*----------------------------------------------------------------*/ /* ** Die durch nptr dargestellte Zahl z wird ersetzt durch exp(z) ** Bei overflow wird aERROR zurueckgegeben */ PUBLIC int expnum(prec,nptr,hilf) int prec; numdata *nptr; word2 *hilf; { word2 *x; long m; int ovfl, n; ovfl = expovfl(nptr,hilf); if(ovfl > 0) return(aERROR); else if(ovfl < 0) { int2numdat(0,nptr); return(0); } m = redmod(prec+1,nptr,LOG2(prec+1),prec+1,hilf); x = hilf; hilf += prec; n = nptr->len - 1; cpyarr(nptr->digits+1,n,x); nptr->len = exp0(prec,x,n,nptr->digits,hilf); nptr->sign = 0; nptr->expo = m - (prec << 4); return(nptr->len); } /*----------------------------------------------------------------*/ PRIVATE int expovfl(nptr,hilf) numdata *nptr; word2 *hilf; { int n; if(nptr->expo <= 1) { cpyarr(nptr->digits,nptr->len,hilf); n = lshiftarr(hilf,nptr->len,nptr->expo); if(n == 0 || (n <= 2 && big2long(hilf,n) < exprange)) return(0); } return(nptr->sign ? -1 : 1); } /*----------------------------------------------------------------*/ /* ** Die durch nptr gegebene Zahl wird destruktiv dargestellt als ** ((nptr->digits,nptr->len) + ret*(modul,modlen)) * (2**16)**(-prec), ** wobei ret der Rueckgabewert ist. ** Die Zahl (nptr->digits,nptr->len) ist nicht negativ und < (2**16)**prec ** ret kann auch negativ sein */ PRIVATE long redmod(prec,nptr,modul,modlen,hilf) int prec, modlen; numdata *nptr; word2 *modul, *hilf; { word2 *x, *quot; word4 u = 0; long ret; int n, len, rlen; x = nptr->digits; len = lshiftarr(x,nptr->len,(prec << 4) + nptr->expo); quot = hilf + prec + 1; n = divbig(x,len,modul,modlen,quot,&rlen,hilf); if(n <= 2) u = big2long(quot,n); if(n > 2 || u >= 0x80000000) { error(scratch("redmod"),err_ovfl,voidsym); return(LONGERROR); } else ret = u; if(nptr->sign) { ret = -ret; if(rlen) { rlen = sub1arr(x,rlen,modul,modlen); ret--; } } nptr->len = rlen; return(ret); } /*----------------------------------------------------------------*/ PUBLIC int lognum(prec,nptr,hilf) int prec; numdata *nptr; word2 *hilf; { word2 *x, *z; word2 aa[2]; word4 u; long expo; int m, n, len; if(nptr->sign || nptr->len == 0) return(aERROR); x = nptr->digits; z = hilf; hilf += prec + 2; normfloat(prec,nptr); n = shlarr(x,prec,1); expo = nptr->expo + (prec << 4) - 1; len = log0(prec,x,n,z,hilf); cpyarr(z,len,x); if(expo) { u = (expo > 0 ? expo : -expo); m = long2big(u,aa); n = multbig(LOG2(prec),prec,aa,m,z,hilf); if(expo > 0) { len = addarr(x,len,z,n); nptr->sign = 0; } else if(cmparr(x,len,z,n) >= 0) { len = subarr(x,len,z,n); nptr->sign = 0; } else { len = sub1arr(x,len,z,n); nptr->sign = MINUSBYTE; } } if(len == 0) int2numdat(0,nptr); else { nptr->len = len; nptr->expo = -(prec << 4); } return(len); } /*----------------------------------------------------------------*/ /* ** Berechnet die Exponentialfunktion von (x,n) * (2**16)**(-prec) ** Ist len der Rueckgabewert, so erhaelt man ** Resultat = (z,len) * (2**16)**(-prec) ** Es wird vorausgesetzt, dass n <= prec ist ** Platz hilf muss mindestens prec + 2 lang sein ** Platz z muss mindestens prec + 1 lang sein */ PRIVATE int exp0(prec,x,n,z,hilf) int prec, n; word2 *x, *z, *hilf; { int len; setarr(z,prec,0); z[prec] = 1; len = prec + 1; while(--n >= 0) len = exp0aux(z,len,x[n],prec-n,hilf); return(len); } /*----------------------------------------------------------------*/ /* ** Multipliziert (x,n) mit exp(a * (2**16)**(-k)) ** Platz temp muss mindestens n + 2 lang sein ** Arbeitet destruktiv auf x !!! */ PRIVATE int exp0aux(x,n,a,k,temp) word2 *x, *temp; unsigned a; int n, k; { int i, m; word2 rest; if(a == 0) return(n); temp++; cpyarr(x,n,temp); m = n; for(i=1; m>k; i++) { m = multarr(temp+k-1,m-k+1,a,temp-1) - 1; m = divarr(temp,m,i,&rest); n = addarr(x,n,temp,m); } return(n); } /*----------------------------------------------------------------*/ /* ** Dividiert (x,n) durch exp(a * (2**16)**(-k)) ** Platz temp muss mindestens n + 2 lang sein ** Arbeitet destruktiv auf x !!! */ PRIVATE int exp1aux(x,n,a,k,temp) word2 *x, *temp; unsigned a; int n, k; { int i, m; word2 rest; if(a == 0) return(n); temp++; cpyarr(x,n,temp); m = n; for(i=1; m>k; i++) { m = multarr(temp+k-1,m-k+1,a,temp-1) - 1; m = divarr(temp,m,i,&rest); n = (i&1 ? subarr(x,n,temp,m) : addarr(x,n,temp,m)); } return(n); } /*----------------------------------------------------------------*/ /* ** Berechnet die Funktion sin(x) von (x,n) * (2**16)**(-prec) ** Ist len der Rueckgabewert so erhaelt man ** Resultat = (z,len) * (2**16)**(-prec) */ PRIVATE int sin0(prec,x,n,z,hilf) int prec, n; word2 *x, *z, *hilf; { word2 *temp, *temp1, *x2; unsigned i; int len, m, m2; m = (prec + 1) << 1; temp = hilf + m; temp1 = temp + m; x2 = temp1 + m; cpyarr(x,n,temp); m = n; cpyarr(temp,m,z); len = m; m2 = multfix(prec,x,n,x,n,x2,hilf); for(i=2; m>0; i+=2) { m = multfix(prec,x2,m2,temp,m,temp1,hilf); cpyarr(temp1,m,temp); if(i<=255) m = divarr(temp,m,i*(i+1),hilf); else { m = divarr(temp,m,i,hilf); m = divarr(temp,m,i+1,hilf); } if(i & 2) len = subarr(z,len,temp,m); else len = addarr(z,len,temp,m); } return(len); } /*----------------------------------------------------------------*/ /* ** Berechnet die Funktion cos(x) von (x,n) * (2**16)**(-prec) ** Ist len der Rueckgabewert so erhaelt man ** Resultat = (z,len) * (2**16)**(-prec) */ PRIVATE int cos0(prec,x,n,z,hilf) int prec, n; word2 *x, *z, *hilf; { word2 *temp, *temp1, *x2; int len, m, m2; unsigned i; m = (prec + 1) << 1; temp = hilf + m; temp1 = temp + m; x2 = temp1 + m; for(i=0; i 0 && z[len-1] == 0) len--; return(len); } /*----------------------------------------------------------------*/ /* ** berechnet 2**16 * log(1 + x*(2**-16)) ** gerundet auf ganze Zahl */ PRIVATE unsigned log1_16(x) unsigned x; { static word4 logtab[] = {0x49A58844,0x108598B5,0x04081596,0x01008055, 0x00400801,0x00100080,0x00040008,0x00010000}; /* log(2**m/(2**m - 1)) * 2**32 fuer m = 2,4,...,16 */ word4 *logptr; word4 xx,d,z; int m; logptr = logtab; z = 0; xx = x; xx <<= 16; m = 1; while(m < 16) { d = xx; d >>= 1; d += 0x80000000; d >>= m; if(xx >= d) { xx -= d; z += *logptr; } else { m += 2; logptr++; } } return(z >> 16); } /*----------------------------------------------------------------*/ /* ** Berechnet die Funktion atan(x) von (x,n) * (2**16)**(-prec) ** Ist len der Rueckgabewert so erhaelt man ** Resultat = (z,len) * (2**16)**(-prec) ** Es wird vorausgesetzt, dass (x,n) < (1/2)*(2**16)**prec ** Platz hilf muss 8*(prec+1) lang sein */ PRIVATE int atan0(prec,x,n,z,hilf) int prec, n; word2 *x, *z, *hilf; { word2 *u, *v, *y, *temp, *temp1, *x2, *arctan; int i, k, m, m1, m2, len; i = (prec+1) << 1; u = temp = hilf; v = temp1 = temp + i; y = x2 = temp1 + i; hilf = x2 + i; len = 0; /* z = 0 */ setarr(u,prec-1,0); u[prec-1] = 0x4000; /* u = 1/4 */ while(cmparr(x,n,u,prec) >= 0) { /* x = (x-u)/(1+u*x) */ arctan = ATAN4(prec); cpyarr(x,n,v); k = shrarr(v,n,2); setarr(v+k,prec-k,0); v[prec] = 1; n = subarr(x,n,u,prec); n = divfix(prec,x,n,v,prec+1,y,hilf); cpyarr(y,n,x); len = addarr(z,len,arctan,prec); } len = addarr(z,len,x,n); cpyarr(x,n,temp); m = n; m2 = multfix(prec,x,n,x,n,x2,hilf); for(i=3; m>1; i+=2) { m = multfix(prec,x2,m2,temp,m,temp1,hilf); cpyarr(temp1,m,temp); m1 = divarr(temp1,m,i,hilf); if(i & 2) len = subarr(z,len,temp1,m1); else len = addarr(z,len,temp1,m1); } return(len); } /******************************************************************/ aribas165b/src/aribas.hlp0000644000076600000240000024165614660570651014353 0ustar ottostaffARIBAS Interpreter for Arithmetic, version 1.60, Aug. 2007 written by 0. Forster, email forster@mathematik.uni-muenchen.de File aribas.hlp for online help for the command line version of ARIBAS. This is not a Windows Help File, but a pure ASCII text file. Under MS-DOS, this file should lie in the same directory as aribas.exe; under UNIX or LINUX, it must be in a directory which is in the search path #---------------------------------------------------------------- Date of last change of this help file: 2007-08-20 #---------------------------------------------------------------- ?if ?then ?else ?elsif if then elsif then else end; There may be more (or zero) elsif parts. The else part may also be absent. Please note the spelling elsif. SEE ALSO: while #---------------------------------------------------------------- ?while ?do while do end; If evaluates to true, the statement sequence is executed (this can change the value of ). If is still true, is again executed. This is repeated until becomes false or the while loop is left by a return or a break statement. SEE ALSO: for, break, continue, return #---------------------------------------------------------------- ?for ?to ?by for-loop: for := to do end; for := to by do end; must be an integer variable, , and must be integer expressions. Example: ==> for k := 9 to 0 by -2 do write(k:3); end. 9 7 5 3 1 SEE ALSO: while, break, continue #---------------------------------------------------------------- ?break break The command break causes (as in C) the immediate leaving of a for or a while loop. Example: ==> for x := 10**7+1 to 10**8 by 2 do if factor16(x) = 0 then break; end; end; x. -: 10000019 SEE ALSO: while, for, continue, factor16 #---------------------------------------------------------------- ?continue continue The continue statement works as in C. If within a while or a for loop the continue statement is encountered, the rest of the current round of the loop is skipped and execution continues with the next round of the loop. Example: ==> for i := 1 to 10 do write(" #"); if i = 7 then continue end; write(i); end. produces the following output: #1 #2 #3 #4 #5 #6 # #8 #9 #10 SEE ALSO: break #---------------------------------------------------------------- ?div ?mod x div y x mod y div and mod are binary, left associative infix operators which may be applied only to integers and give an integer result. x div y returns the greatest integer less than or equal to x/y. The operator mod is defined by the equation x = (x div y) * y + (x mod y) The divisor y must be non-zero. SEE ALSO: divide #---------------------------------------------------------------- ?divide divide(x,y: integer): array[2]; Returns a pair (q,r) of integers such that q = x div y and r = x mod y. The argument \cc{y} must be non-zero. Example: ==> divide(100,7). -: (14, 2) ==> divide(-100,7). -: (-15, 5) SEE ALSO: div #---------------------------------------------------------------- ?boolean ?true ?false boolean The data type boolean comprises the truth values false and true. The logical operators not, and, or apply to boolean operands in the usual way and yield boolean results. Boolean values are also the result of arithmetic relational operators. In every place where ARIBAS expects a boolean value (e.g. as conditions in the if or while constructions), one can also use integer values. Then the value 0 is considered as false and every nonzero integer counts as true (this is the same behaviour as in the programming language C). SEE ALSO: and, or, not, if #---------------------------------------------------------------- ?not ?and ?or not, and, or not is a unary prefix operator, whereas and, or are binary infix operators. They may be applied to boolean arguments. The evaluation of the arguments of the binary operators and, or proceeds from left to right and is stopped as soon as the result is determined. Thus an expression like u > 0 and v/u < 1 is admissible, which would generate an error for u=0 if always both arguments of the and-operator were evaluated. SEE ALSO: boolean #----------------------------------------------------------------------- ?set_printbase set_printbase(b: integer): integer; The integer b must be one of the numbers 2, 8, 10, 16. The effect of this function is that subsequent output of integers is done in base b representation. Return value is the newly set print base. (If b is not admissible, the old print base is not altered.) Example: ==> set_printbase(8). -: 0o10 ==> 255. -: 0o377 For integers written in bases other than 10, the following prefixes are used: 0x for base 16, 0o for base 8 and 0y for base 2. SEE ALSO: get_printbase #---------------------------------------------------------------- ?get_printbase get_printbase(): integer; Returns the print base which is currently used. SEE ALSO: set_printbase #---------------------------------------------------------------- ?max_intsize max_intsize(): integer; Returns the maximum number of decimal places of integers supported by ARIBAS. This number depends on the options when ARIBAS was compiled and is typically between 20000 and 64000. SEE ALSO: integer #---------------------------------------------------------------- ?sum ?product sum(vec: array of integer): integer; sum(vec: array of real): real; product(vec: array of integer): integer; product(vec: array of real): real; Returns the sum resp. the product of all components of vec. SEE ALSO: max, min #---------------------------------------------------------------- ?even ?odd even(x: integer): boolean; odd(x: integer): boolean; Tests if x is even resp. odd. #---------------------------------------------------------------- ?max ?min max(x1,...,xn: integer): integer; max(x1,...,xn: real): real; min(x1,...,xn: integer): integer; min(x1,...,xn: real): real; Returns the maximum (resp. minimum) of the arguments x1,...,xn. max(vec: array of integer): integer; max(vec: array of real): real; min(vec: array of integer): integer; min(vec: array of real): real; Returns the maximum (resp. minimum) of all components of vec. #---------------------------------------------------------- ?abs abs(x: integer): integer; abs(x: real): real; Returns the absolute value of x. #---------------------------------------------------------- ?inc inc(var x: integer [; delta: integer]): integer; Increases the integer variable x by delta (by default delta = 1) und returns the increased value of x. Functionally equivalent to x := x + delta. The variable parameter x may also be an array element. Be aware of side effects; constructions like inc(vec[inc(k)]) may lead to an unexpected result! SEE ALSO: dec #---------------------------------------------------------- ?dec dec(var x: integer [; delta: integer]): integer; Decreases the integer variable x by delta (by default delta = 1) und returns the decreased value of x. Functionally equivalent to x := x - delta. The variable parameter x may also be an array element. Be aware of side effects; constructions like dec(vec[dec(k)]) may lead to an unexpected result! SEE ALSO: inc #---------------------------------------------------------- ?gcd gcd(x1,...,xn: integer): integer; Returns the greatest common divisor of the integers x1,x2,...,xn. For n = 1, one has gcd(x) = abs(x); if n = 0, then gcd() = 0. gcd(vec: array of integer): integer; Returns the greatest common divisor of all components of vec. SEE ALSO: gcdx #---------------------------------------------------------- ?gcdx gcdx(x,y: integer; var u,v: integer): integer; Returns the greatest common divisor d of x, y. At the same time, the variables u and v are set to values such that d = u*x + v*y Example: ==> gcdx(7,12,u,v). -: 1 ==> (u,v). -: (7, -4) SEE ALSO: gcd, mod_inverse #---------------------------------------------------------- ?mod_inverse mod_inverse(x, mm: integer): integer; If x and mm are reatively prime, this function returns the inverse of x modulo mm. Otherwise the return value is 0. Examples: ==> mod_inverse(3,17). -: 6 ==> mod_inverse(3,18). -: 0 SEE ALSO: gcdx #-------------------------------------------------------------- ?isqrt isqrt(x: integer): integer; x must be a non-negative integer. Returns the greatest integer y such that y*y <= x. SEE ALSO: sqrt, gfp_sqrt #------------------------------------------------------------- ?gfp_sqrt gfp_sqrt(p,x: integer): integer; p must be an odd prime and x an integer which is a square modulo p, i.e. jacobi(x,p) /= -1. The function returns a square root of x modulo p, that is, a square root in the field GF(p). Example: ==> p := next_prime(10**6). -: 1000003 ==> x := 10. -: 10 ==> jacobi(x,p). -: 1 ==> y := gfp_sqrt(p,x). -: 394215 ==> y**2 mod p. -: 10 SEE ALSO: isqrt #------------------------------------------------------------- ?factorial factorial(n: integer): integer; n must be a non-negative integer. Returns the factorial of n, (usually denoted by n!). Example: ==> factorial(8). -: 40320 #------------------------------------------------------------- ?mod_coshmult mod_coshmult(x,s,mm: integer): integer; If x is an integer and xi a number such that cosh(xi) = x, then cosh(s*xi) is an integer for all natural numbers s. The function returns this number modulo mm. The result can be obtained by the following recursively defined (Lucas) sequence: a(0) := 1; a(1) := x; a(k+2) := 2*x*a(k+1) - a(k); The result is the number a(s) mod mm. This function is useful to implement the (p+1)-factorization method. SEE ALSO: mod_pemult #------------------------------------------------------------- ?mod_pemult mod_pemult(x,s,a,mm: integer): array[2] of integer; Let pe be the Weierstrass pe-function on the elliptic curve E(a) y*y = x*x*x + a*x*x + x and let xi be a point on the curve with pe(xi) = x. Then s*xi is a point of E(a) (with respect to the abelian group structure on the elliptic curve). If s*xi is not a pole of pe, then pe(s*xi) = u/v is a rational number. (We may suppose that u and v are relatively prime.) If v is relatively prime to mm, the function mod_pemult(x,s,a,mm) returns (z,1), where z is an integer satisfying z*v = u mod mm (i.e. we have z = u/v in Z/mmZ). If v and mm have a greatest common divisor d > 1, the function returns (d,0). If s*xi is a pole of pe, the return value is (mm,0). This function is useful for the factorization with elliptic curves. SEE ALSO: mod_coshmult #--------------------------------------------------------------- ?factor16 factor16(x [,x0 [,x1]]: integer): integer; factor16(x) seeks a prime divisor p of x with p < min(2**16,x). If such a prime divisor exists, the smallest one is returned. Otherwise the function returns 0. If the optional arguments x0 resp. x0 and x1 are supplied, only prime divisors p satisfying the additional conditions p >= x0 resp. x0 <= p <= x1 are considered. Examples: ==> factor16(2**32 + 1). -: 641 ==> factor16(2**32 + 1, 642). -: 0 SEE ALSO: prime32test, rho_factorize #------------------------------------------------------------- ?prime32test prime32test(x: integer): integer; Tests if abs(x) is a prime number < 2**32. If this is true, the function returns 1. If abs(x) < 2**32, but is not prime, 0 is returned. For abs(x) >= 2**32, the function returns -1. SEE ALSO: rab_primetest, factor16 #------------------------------------------------------------ ?rab_primetest rab_primetest(x: integer): boolean; Performs the Rabin probabilistic prime test. If the function returns false, the number is certainly composite. A 'random ' number x, for which factor16(x) = 0 and rab_primetest(x) = true is prime with high probability. An exception are numbers constructed purposely to fool the Rabin prime test. But also for these numbers the error probability is less than 1/4. To decrease the error probability, one can repeat the test several times. SEE ALSO: prime32test, factor16 #---------------------------------------------------------- ?jacobi jacobi(a,m: integer): integer; Returns the Jacobi symbol of a over m. The module m must be an odd integer; a may be an arbitrary integer, the result depends only on the residue class of a modulo m. If a and m are not relatively prime, the return value is 0, otherwise it is 1 or -1. If p is an odd prime and a not a multiple of p, then jacobi(a,p) = 1 if and only if a is a quadratic residue modulo p. #------------------------------------------------------------ ?rho_factorize rho_factorize(x:integer [; b: integer]): integer; Tries to factorize x using Pollard's rho-algorithm. The optional argument b is a bound for the maximal number of steps (default value b = 2**16). If the algorithm finds a factor, it is returned, in case of failure the return value is 0. The number x should be free of small prime factors (e.g. < 1000). Then, if x has a prime factor p < sqrt(x), the algorithm will in general find a factorization of x if b is a small multiple of sqrt(p). If the return value y is > 1 and < x, it is certainly a factor of x, but not necessarily prime. rho_factorize(x,0). rho_factorize(x,b,0). Silent version. With last argument 0, all messages to the screen are suppressed. SEE ALSO: cf_factorize, qs_factorize, factor16 #---------------------------------------------------------------- ?cf_factorize cf_factorize(x: integer [; mm: integer]): integer; Tries to factorize x using the Morrison-Brillhart continued fraction factorization algorithm. The run time does not depend on the size of the prime factors of x. (Hence, if it is known that x has small prime factors, another factorization method like rho_factorize should be used.) If the period of the continued fraction of sqrt(x) is too short, the factorization will fail. In this case one should supply a second argument, which must be an integer mm with 1 <= mm < 1024. Then the continued fraction expansion of sqrt(mm*x) will be used. cf_factorize(x,0). cf_factorize(x,mm,0). Silent version. With last argument 0, all messages to the screen are suppressed. SEE ALSO: rho_factorize, qs_factorize #---------------------------------------------------------------- ?qs_factorize qs_factorize(x: integer): integer; Tries to factorize x using the multiple polynomial quadratic sieve factorization algorithm. The run time does not depend on the size of the prime factors of x. (Hence, if it is known that x has small prime factors, another factorization method like rho_factorize should be used.) qs_factorize(x,0). Silent version. With second argument 0, all messages to the screen are suppressed. SEE ALSO: rho_factorize, cf_factorize, ec_factorize #------------------------------------------------------------------- ?ec_factorize ec_factorize(x: integer[; m: integer]): integer; Tries to factorize x by the elliptic curve method. The optional argument m is a bound for the number of elliptic curves used. If the algorithm finds a factor, it is returned, in case of failure the return value is 0. If the return value y is > 1, it is certainly a factor of x, but not necessarily prime. ec_factorize(x: integer; pbounds: array[2] [; m: integer]): integer; You may explicitely prescribe the prime bound and the bigprime bound by the second argument in form of a 2-dimensional vector pbounds = (bound1,bound2). The constant bound1 must be < 2**16 and bound2 < 2**24. The third optional argument m is the maximal number of elliptic curves used. SEE ALSO: qs_factorize #------------------------------------------------------------------- ?next_prime next_prime(x: integer): integer; Returns the smallest prime p >= x. If x > 2**32, p is only a prime with high probability, since the probabilistic Rabin primality test is used. The number returned has no prime factor < 2**16 and has passed the strong pseudo prime test with ten random bases. next_prime(x,0). Silent version. With second argument 0, all messages to the screen are suppressed. SEE also: rab_primetest #------------------------------------------------------------------- ?bit_test bit_test(x,n: integer): integer; Returns 1, if the bit in position n of x is set, otherwise returns 0. Negative integers are thought to be in two's complement representation, where the sign bit extends to infinity at the left hand side. For example, the bit pattern of the two's complement representation of -1 is ......11111111111111111111111111111111 The count of positions begins with 0 (the bit i position n has weigth 2**n). For example, bit_test(x,0) = 1 if and only if x is odd. SEE ALSO: bit_set, bit_clear #---------------------------------------------------------------- ?bit_set bit_set(x,n: integer): integer; Sets the bit in position n of the integer x equal to 1 and returns the modified integer. Example: ==> bit_set(16,2). -: 20 SEE ALSO: bit_test, bit_clear #---------------------------------------------------------------- ?bit_clear bit_clear(x,n: integer): integer; Clears the bit in position n of the integer x (i.e. sets it equal to 0) and returns the modified integer. Examples: ==> bit_clear(20,2). -: 16 ==> bit_clear(-1,0). -: -2 SEE ALSO: bit_test, bit_set #---------------------------------------------------------------- ?bit_shift bit_shift(x,n: integer): integer; The number n may be positive, negative or zero. If n >= 0, bit_shift(x,n) is a shift of the bit representation of x of n positions to the left (i.e. in direction of more significant bits); this is equivalent to a multiplication by 2**n. If n < 0, this is a shift of abs(n) positions to the right (i.e. in direction of less significant bits); equivalent to x div 2**abs(n). Examples: ==> bit_shift(-7,3). -: -56 ==> bit_shift(-7,-1). -: -4 ==> bit_shift(-7,-100). -: -1 SEE ALSO: bit_test #---------------------------------------------------------------- ?bit_not bit_not(x: integer): integer; Inverts all bits of x. Equivalent to -x-1. SEE ALSO: bit_test, bit_and #---------------------------------------------------------------- ?bit_and ?bit_or ?bit_xor bit_and(x,y: integer): integer; bit_or(x,y: integer): integer; bit_xor(x,y: integer): integer; Bitwise and, or resp. exclusive or of x and y. For example, bit_and(x,3) is equivalent to x mod 4. SEE ALSO: bit_not, bit_test #---------------------------------------------------------------- ?bit_length bit_length(x: integer): integer; Returns the smallest natural number n such that abs(x) < 2**n SEE ALSO: bit_count, bit_test #---------------------------------------------------------------- ?bit_count bit_count(x: integer): integer; Returns the number of bits equal to 1 in the binary representation of abs(x). Examples: ==> bit_count(0). -: 0 ==> bit_count(255). -: 8 ==> x := 10001. -: 10001 ==> write(x:base(2)). 100111_00010001 -: 1 ==> bit_count(x). -: 6 ==> bit_count(-x). -: 6 SEE ALSO: bit_test, bit_length #---------------------------------------------------------------- ?pi constant pi ==> pi. -: 3.14159265 Internally, pi is stored with a precision equal to max_floatprec(). ==> set_floatprec(long_float). -: 128 ==> pi. -: 3.14159_26535_89793_23846_26433_83279_50288_4 SEE ALSO: arctan2, set_floatprec, max_floatprec #---------------------------------------------------------------- ?real real The data type real comprises a computer approximation of the real numbers. Real literals are given in decimal representation, beginning with an optional sign + or -, then a non-empty sequence of decimal digits, an obligatory decimal point, a second non-empty sequence of decimal digits and an optional scaling factor, consisting of the symbol E (or e), an optional sign and a non-empty sequence of decimal digits. Examples: 0.3 +3.1e-45 -0.00007E1000 The following forms are not admissible real literals: .333 333e-3. (The number which is meant by these symbols may be represented by 0.333 or 333.0e-3). SEE ALSO: set_floatprec, get_floatprec, decode_float, float #---------------------------------------------------------------- ?floor floor(x: real): integer; Returns the greatest integer n <= x. Examples: ==> floor(pi). -: 3 ==> floor(-pi). -: -4 SEE ALSO: trunc, round #---------------------------------------------------------------- ?trunc trunc(x: real): integer; If x >= 0, equivalent to floor(x). For x < 0, trunc(x) = -trunc(-x). Examples: ==> trunc(pi). -: 3 ==> trunc(-pi). -: -3 SEE ALSO: floor, round, frac #---------------------------------------------------------------- ?frac frac(x: real): real; Defined by the equation x = trunc(x) + frac(x) Examples: ==> frac(1.23). -: 0.230000000 ==> frac(-1.23). -: -0.230000000 SEE ALSO: trunc #---------------------------------------------------------------- ?round round(x: real): integer; Rounds x to the next integer n. If x has exactly the distance 1/2 from two integers, rounds to the even integer. Examples: ==> round(pi). -: 3 ==> round(3.5). -: 4 ==> round(2.5). -: 2 SEE ALSO: floor, trunc #---------------------------------------------------------------- ?set_floatprec ?single_float ?double_float ?long_float set_floatprec(bb: integer): integer; set_floatprec(Floattype): integer; This function serves to set the precision (in bits) which is used for subsequent calculations with reals. By default, a precision of 32 bits is used (corresponding to 9-10 decimal places), but it can be set to several higher values up to an implementation dependent limit, which can be determined by the function max_floatprec(). The argument of set_floatprec is either an integer bb, indicating the number of bits. If necessary, bb is rounded to the next higher available precision. The argument can also be a symbol Floattype, for which the following choice is available: single_float: 32 bits double_float: 64 bits long_float: 128 bits The function returns the new float precision. Example: ==> set_floatprec(long_float); x := sqrt(2). -: 1.41421356237309504880168872420969808 SEE ALSO: get_floatprec, max_floatprec #---------------------------------------------------------------- ?get_floatprec get_floatprec(): integer; get_floatprec(x: real): integer; In the first form (without arguments), the function returns the current float precision (in bits, i.e. one of the numbers 17, 32, 64, 128, 192). The default float precision of ARIBAS is 32 bits. If the argument is a real number x, the precision of x is returned. Examples: ==> set_floatprec(200). -: 256 ==> get_floatprec(pi). -: 4096 ==> get_floatprec(1/3). -: 256 SEE ALSO: set_floatprec, decode_float #---------------------------------------------------------------- ?max_floatprec max_floatprec(): integer; This function returns the maximum floating point precision (in bits) which is available in the current implementation of ARIBAS. Example: ==> max_floatprec(). -: 4096 SEE ALSO: set_floatprec, get_floatprec #---------------------------------------------------------------- ?decode_float decode_float(x: real): array[2] of integer; For a real number x, the function decode_float(x) returns a pair (mant, expo) of integers, reflecting the internal representation of x. The following equation holds: x = mant * 2**expo Example: ==> set_printbase(16). -: 0x10 ==> decode_float(-1/3). -: (-0xAAAA_AAAA, -0x21) SEE ALSO: get_floatprec, set_printbase, float #---------------------------------------------------------------- ?float float(x: integer [; Floattype]): real; float(x: real [; Floattype]): real; Floattype must be one of the symbols single_float, double_float, long_float or an integer bb indicating the float precision in bits. If this argument is not given, the current float precision is assumed. The function transforms the number x to data type real with float precision Floattype. Example: Suppose that the current float precision is single_float. ==> float(5). -: 5.00000000 SEE ALSO: set_floatprec, decode_float #---------------------------------------------------------------- ?sqrt ?exp ?log ?sin ?cos ?tan ?arctan ?arcsin ?arccos sqrt(x: real): real; exp(x: real): real; log(x: real): real; sin(x: real): real; cos(x: real): real; tan(x: real): real; arctan(x: real): real; arcsin(x: real): real; arccos(x: real): real; The functions sqrt (square root), exp, log (natural logarithm), sin, cos, tan, arctan, arcsin, arccos all expect one real argument and return a real. If the argument is an integer, it is automatically transformed to a real. Example: ==> log(2). -: 0.693147180 SEE ALSO: arctan2, set_floatprec, pi, isqrt #---------------------------------------------------------------- ?arctan2 arctan2(y,x: real): real; The two numbers x,y may not be simultaneously 0. The function returns an angle phi with -pi < phi <= pi, satisfying x = r * cos(phi); y = r * sin(phi); where r = sqrt(x*x + y*y). If x > 0, then arctan2(y,x) = arctan(y/x). ==> arctan2(0,-1). -: 3.14159265 SEE ALSO: arctan, pi #---------------------------------------------------------------- ?random random(x: integer): integer; random(x: real): real; Returns an integer (resp. real) pseudo random number z with 0 <= z < x. SEE ALSO: random_seed #---------------------------------------------------------- ?random_seed random_seed([s: integer]): integer; random_seed without an argument returns the present state of the random generator (which is an integer z with 2**48 <= z < 2**49). With an integer argument s, the state of the random generator is set to a value z such that z = s mod 2**48 and 2**48 <= z < 2**49. In this way one can generate reproducible values of the random function (for test purposes). SEE ALSO: random #---------------------------------------------------------- ?char char The data type char comprises 256 characters with code numbers 0 to 255. Characters with code numbers < 128 are the standard ASCII characters (they comprise printable characters and control characters); characters with code number >= 128 are system dependent. Character literals of printable characters are given by enclosing the symbol between single quotes, as in 'A'. The function chr transforms integer values from 0 to 255 into the corresponding characters. In this way, also the non-printable characters can be generated. For example, chr(7) is the bell character (which usually generates a beep when output to the terminal). SEE ALSO: chr, ord, string #---------------------------------------------------------- ?chr ?ord chr(n: integer): char; ord(ch: char): integer; The function chr generates the character with ASCII-Code n (0 <= n < 256), ord is the inverse function of chr. Examples: ==> chr(63). -: '?' ==> ord('?'). -: 63 SEE ALSO: char #----------------------------------------------------------*) ?concat concat(arg0, arg1, ... , argn): string; The function concat expects one or more arguments which must be strings or characters. The result is a string which is the concatenation of all arguments. Example: ==> concat("string",'_',"split"). -: "string_split" Using concat, one can construct strings with embedded double quotes: ==> concat("123",'"',"456"). -: "123"456" SEE ALSO: string_split #------------------------------------------------------------ ?toupper toupper(str: string): string; toupper(ch: character): character; Transforms a string resp. a character to upper case. Only characters between 'a' and 'z' are affected. All others remain untouched. Example: ==> toupper("Zapp-up!"). -: "ZAPP-UP!" SEE ALSO: tolower #------------------------------------------------------------- ?tolower tolower(str: string): string; tolower(ch: character): character; Transforms a string resp. a character to lower case. Only characters between 'A' and 'Z' are affected. All others remain untouched. Examples: ==> tolower("ABCdef123"). -: "abcdef123" ==> tolower('Z'). -: 'z' SEE ALSO: toupper #---------------------------------------------------------- ?string_split string_split(str: string [; sep: string]): array of string; Splits the string str into one or more parts and returns a vector whose components are these parts. The splitting considers as separators the characters contained in the string sep. If the argument sep is not supplied, SPACE, TAB, CR and NEWLINE are used by default. Examples; ==> string_split("abc def"). -: ("abc", "def") ==> string_split("abc def;xxx=yyy",";= "). -: ("abc", "def", "xxx", "yyy") SEE ALSO: concat #---------------------------------------------------------- ?substr_index substr_index(str, str1: string): integer; Searches for an occurrence of str1 as a substring of str and returns the position (the count begins with 0). If str1 does not occur as a substring of str, -1 is returned. Examples: ==> substr_index("string_split","split"). -: 7 ==> substr_index("string_split","Split"). -: -1 SEE ALSO: string_scan #---------------------------------------------------------- ?string_scan string_scan(str, set: string [; mode: boolean]): integer; When mode=true (default), searches for the first occurrence of a character from the string set in the string str and returns its position. If no character from set occurs in str, -1 is returned. Example: ==> str := "vec := (1,2,3)". -: "vec := (1,2,3)" ==> string_scan(str,"+-()"). -: 7 ==> string_scan(str,"+-[]"). -: -1 If mode=false, then the function searches for the first character in str, that does not belong to set. If all characters of str occur in set, then -1 is returned. For example, string_scan(str,"0123456789",false) = -1 is true if and only if the string str consists entirely of digits. SEE ALSO: substr_index #---------------------------------------------------------- ?itoa itoa(x: integer [; base: integer]): string; The integer x is converted to a string, giving the textual representation of this integer. The second optional argument is the base to be used, which may have one of the values 2,8,10,16. By default, base 10 is used. Example: ==> itoa(1234). -: "1234" ==> itoa(1234,16). -: "4D2" SEE ALSO: atoi, ftoa #------------------------------------------------------------ ?ftoa ftoa(x: real): string; The real number x is converted to a string. Examples: ==> ftoa(1/239). -: "0.00418410042" ==> ftoa(pi*10**100). -: "3.14159265E100" SEE ALSO: float_ecvt, itoa #---------------------------------------------------------- ?atoi atoi(s: string [; var len: integer]): integer; A string s, representing an integer, is transformed to this integer. The function may be called with an optional second variable argument len. The function stores in len an integer, which in general is the length of the string s. If len < length(s), then only the substring containing the first len characters of s is an admissible representation of an integer. In particular len=0 indicates a non-admissible string. Examples: ==> atoi("1234"). -: 1234 ==> atoi("0xFF 1234",len). -: 255 ==> len. -: 4 SEE ALSO: itoa, atof #---------------------------------------------------------- ?atof atof(s: string [; var len: integer]): real; A string s, representing a real number, is transformed to this real. The function may be called with an optional second variable argument len. The function stores in len an integer, which in general is the length of the string s. If len < length(s), then only the substring containing the first len characters of s is an admissible representation of a real. In particular len=0 indicates a non-admissible string. SEE ALSO: ftoa, atoi #---------------------------------------------------------- ?float_ecvt float_ecvt(x: real; ndig: integer; var decpos, sign: integer): string; The real x is transformed to a string of length ndig. The string contains only digits. The position of the decimal point is returned in the variable paramenter decpos (decpos < 0 means that the decimal point is to the left of the beginning of the string). The sign of x is returned in the variable parameter sign (sign = 0 means x >= 0, sign /= 0 means x < 0). float_ecvt is analogous to the UNIX C-function ecvt. Example: ==> float_ecvt(pi,10,decpos,sign). -: "3141592654" ==> decpos. -: 1 ==> sign. -: 0 SEE ALSO: ftoa #------------------------------------------------------------- ?md5 md5(str: string): byte_string; md5(str: byte_string): byte_string; Calculates the md5 fingerprint of the string (resp. byte_string) str. Example: ==> md5("1234567890"). -: $E807_F1FC_F82D_132F_9BB0_18CA_6738_A19F #------------------------------------------------------------- ?cardinal cardinal(b: byte_string): integer; Transforms a byte_string into a non-negative integer. The components of the byte_string are considered as the digits of an integer with respect to base 256. The leftmost byte corresponds to the least significant digit. Therefore the function returns the integer sum(b[i] * 256**i: 0 <= i < length(b)). Example: ==> cardinal($000A). -: 2560 SEE ALSO: integer, byte_string #---------------------------------------------------------- ?integer integer default data type of ARIBAS ARIBAS can handle integers of up to 20000 decimal digits. (*--------------------------------------------------------*) integer(b: byte_string): integer; Transforms a byte_string into an integer. The components of the byte_string are considered as the digits of an integer with respect to base 256 in two's complement representation. If len := length(b) and the most significant bit of b[len-1] is not set, then integer(b) = cardinal(b). But if the most significant bit of b[len-1] is set, then integer(b) = cardinal(b) - 256**len. SEE ALSO: cardinal, byte_string #----------------------------------------------------------------------- ?gf2nint gf2nint Data type of elements of the fields GF(2**n) of characteristic 2. To be able to do arithmetic in GF(2**n), the field must be initialized by the command gf2n_init(n). The elements of GF(2**n) are represented by polynomials of degree < n with coefficients 0 or 1, i.e. by bitvectors of length <= n. Literals of data type gf2nint are marked by the prefix 2x, followed by the hexadecimal representation of this bitvector. For example, in the field GF(2**8), the element 2x8A represents the class of the polynomial X**7 + X**3 + X, since 2**7 + 2**3 + 2 = 138 = 0x8A = 0y10001010. Also binary and octal representations are admissible; these are marked with the prefixes 2y and 2o respectively. For example, 2x8A = 2y10001010 = 2o212. Elements of data type gf2nint can be added, mulitiplied, divided and raised to integer powers: x + y, x*y, x/y, x**n. gf2nint(x: integer): gf2nint; Converts an integer to an element of data type gf2nint. Inverse function is integer(x: gf2nint): integer; SEE ALSO: gf2n_init, gf2n_fieldpol, gf2n_degree, gf2n_trace #---------------------------------------------------------- ?gf2n_init gf2n_init(deg: integer): integer; Initializes the field GF(2**deg), which is an extension of degree deg of the field with two elements GF(2). Return value is an integer f, representing an irreducible polynomial of degree deg. If the integer f in binary representation is f = sum(a_i * 2**i, i=0,1,...,deg), a_i = 0,1, then the corresponding polynomial f(X) in GF(2)[X] is f(X) = sum(a_i * X**i, i=0,1,...,deg). The field GF(2**deg) is constructed as GF(2)[X]/(f(X)). Example: ==> gf2n_init(53). -: 9_00719_92547_41063 ==> write(_:base(2)). 100000_00000000_00000000_00000000_00000000_00000000_01000111 -: 1 In this case the irreducible polynomial serving to construct the field GF(2**53) is f(X) = X**53 + X**6 + X**2 + X + 1. SEE ALSO: gf2nint, gf2n_fieldpol, gf2n_degree, max_gf2nsize, gf2n_trace #----------------------------------------------------------------------- ?gf2n_fieldpol gf2n_fieldpol(): integer; Returns the irreducible polynomial defining the field GF(2**n) which is active at present. The polynomial is represented by an integer; see description of the function gf2n_init(). SEE ALSO: gf2n_init, gf2n_degree, gf2nint #----------------------------------------------------------------------- ?gf2n_degree gf2n_degree(): integer; Returns the degree of the field GF(2**n) which is currently active. SEE ALSO: gf2n_init, gf2nint #----------------------------------------------------------------------- ?gf2n_trace gf2n_trace(z: gf2nint): integer; Returns the trace 0 or 1 of an element z in GF(2**n). The trace of z is 0 if and only if the quadratic equation x**2 + x = z has a solution x in GF(2**n). SEE ALSO: gf2n_init, gf2nint #----------------------------------------------------------------------- ?max_gf2nsize max_gf2nsize(): integer; Returns the maximal degree of a field GF(2**n) supported by the current version of ARIBAS. SEE ALSO: gf2n_init, gf2n_degree, gf2nint #----------------------------------------------------------------------- ?gf2X ARIBAS has several builtin functions dealing with polynomials over the field GF(2) with two elements 0,1. In these functions, polynomials are represented by integers. The correspondence is defined as follows: The integer f = sum( ai * 2**i, 0 <= i <= n), ai = 0,1 represents the polynomial F(X) = sum( ai * X**i, 0 <= i <= n). For example, ==> f := 2**7 + 2**6 + 1. -: 193 represents the polynomial F(X) = X**7 + X**6 + 1. SEE ALSO: gf2X_mult, gf2X_div, gf2X_gcd, gf2X_primetest #----------------------------------------------------------------------- ?gf2X_mult gf2X_mult(f,g: integer): integer; Multiplies two polynomials over GF(2) given by the integers f, g. Example: ==> f := 2**7 + 2**6 + 1. -: 193 ==> g := 2**6 + 2**4 + 1. -: 81 ==> h := gf2X_mult(f,g). -: 15505 ==> write(h:base(2)). 111100_10010001 -: 1 The product h represents the polynomial H(X) = X**13 + X**12 + X**11 + X**10 + X**7 + X**4 + 1. SEE ALSO: gf2X, gf2X_square, gf2X_divide #----------------------------------------------------------------------- ?gf2X_square gf2X_square(f: integer): integer; gf2X_square(f) is functionally equivalent to gf2X_mult(f,f), but runs faster. SEE ALSO: gf2X, gf2X_mult, gf2X_modpower #----------------------------------------------------------------------- ?gf2X_divide ?gf2X_div ?gf2X_mod gf2X_divide(f,g: integer): array[2]; gf2X_div(f,g: integer): integer; gf2X_mod(f,g: integer): integer; If f and g are two polynomials over GF(2) and g /= 0, then there exist polynomials q and r with deg(r) < deg(g) such that f = q*g + r The function gf2X_divide(f,g) returns the pair (q,r), the function gf2X_div(f,g) returns the quotient q and gf2X_mod(f,g) returns the remainder r. SEE ALSO: gf2X_mult, gf2X_gcd, gf2X_modpower #----------------------------------------------------------------------- ?gf2X_gcd gf2X_gcd(f,g: integer): integer; Returns the greatest common divisor of the polynomials f,g. Example: ==> f := 2**10 + 1. -: 1025 ==> g := 2**4 + 1. -: 17 ==> gf2X_gcd(f,g). -: 5 This shows that the gcd of the polynomials X**10 + 1 and X**4 + 1 is X**2 + 1. SEE ALSO: gf2X, gf2X_mod #----------------------------------------------------------------------- ?gf2X_modpower gf2X_modpower(g,n,F: integer): integer; Calculates the n-th power of the polynomial g modulo the polynomial F. Example: ==> g := 2**5 + 2**4 + 1. -: 49 ==> F := 2**10 + 1. -: 1025 ==> h := gf2X_modpower(g,12345,F). -: 67 ==> write(h:base(2)). 1000011 -: 1 Thus (X**5 + X**4 + 1)**12345 = (X**6 + X + 1) mod (X**10 + 1). SEE ALSO: gf2X, gf2X_mult, gf2X_square, gf2X_mod #----------------------------------------------------------------------- ?gf2X_primetest gf2X_primetest(f: integer): boolean; Tests whether the polynomial f is irreducible. Example: ==> f0 := 2**100 + 1. -: 1_26765_06002_28229_40149_67032_05377 ==> for k := 1 to 99 do f := f0 + 2**k; if gf2X_primetest(f) then writeln(k); break; end; end; f. 15 -: 1_26765_06002_28229_40149_67032_38145 This shows that the polynomial X**100 + X**15 + 1 is irreducible over GF(2). SEE ALSO: gf2X, gf2nint #----------------------------------------------------------------------- ?byte_string A byte_string is a finite sequence of bytes. Byte_string literals are written in the form $XXXXXX...XX, where XX stands for the hexadecimal representation of a byte. (*--------------------------------------------------------------------*) byte_string(x: integer [; len: integer]): byte_string; byte_string(x) transforms an integer x into a byte_string of length len (default = byte_length(x)). It is the inverse function of integer(bb: byte_string). If a second argument len is given and len < byte_length(x), then the byte_string is truncated and only the len least significant bytes are retained. If len > byte_length(x), bytes of value 0 (if x >= 0) resp. 0xFF (if x < 0) are added. Example: ==> byte_string(-1,4). -: 0xFFFF_FFFF (*--------------------------------------------------------------------*) byte_string(s: string): byte_string; Transforms an ordinary (text) string into a byte_string. The components of the resulting byte_string are the ASCII codes of the characters of s. SEE ALSO: integer, string #---------------------------------------------------------- ?string string The data type string comprises sequences of characters and serves to represent text. String literals are given by enclosing the character sequence between double quotes, as in "ABCD". Strings containing double quotes can be constructed using concat. One can access a single character of a string in the following way: ==> s := "abcdef"; s[3]. -: 'd' (*---------------------------------------------------------*) string(b: byte_string): string; Transforms a byte_string into a text string; inverse function of byte_string. Be careful if some components of the byte_string b are codes of non-printable control characters. SEE ALSO: byte_string, char, concat #------------------------------------------------------------- ?mem_btest mem_btest(var b: byte_string; n: integer): integer; Returns the value 1 or 0 of the bit at position n in the byte_string b (position is zero based). SEE ALSO: mem_bset, mem_bclear #---------------------------------------------------------- ?mem_bset mem_bset(var b: byte_string; n: integer): byte_string; Sets the bit at position n in the byte_string b to 1 and returns the modified byte_string. SEE ALSO: mem_bclear, mem_btest #---------------------------------------------------------- ?mem_bclear mem_bclear(var b: byte_string; n: integer): byte_string; Clears the bit at position n in the byte_string b (i.e. sets it to 0) and returns the modified byte_string. SEE ALSO: mem_bset, mem_btest, mem_not #---------------------------------------------------------- ?mem_not mem_not(var b: byte_string): byte_string; Inverts all bits in the byte_string b and returns the modified byte_string. SEE ALSO: mem_xor #---------------------------------------------------------- ?mem_or ?mem_and ?mem_xor mem_and(var b1,b2: byte_string): byte_string; mem_or(var b1,b2: byte_string): byte_string; mem_xor(var b1,b2: byte_string): byte_string; The first byte_string argument b1 is replaced by the bitwise and (resp. or, xor) of b1 and b2. The modified byte_string b1 is returned. SEE ALSO: mem_not, mem_shift, mem_btest #---------------------------------------------------------- ?mem_shift mem_shift(var b: byte_string; n: integer): byte_string; Performs a bit shift by abs(n) binary digits. If n > 0, the direction is from least-significant to most-significant, for n < 0, the shift is in the opposite direction. n bits are lost. They are replaced by 0's. Example: ==> bb := $ABCD; mem_shift(bb,4). -: $B0DA ==> mem_shift(bb,4). -: $00AB SEE ALSO: mem_not, mem_xor #---------------------------------------------------------- ?mem_bitswap mem_bitswap(var b: byte_string): byte_string; Within each byte of b, the 8 bits are swapped from most significant <--> least significant, that is, sum{b_k*2**k, 0 <= k < 8} is replaced by sum{b_k*2**(7-k), 0 <= k < 8}. The modified byte_string is returned. Example: ==> bb := $0102_1e2f. -: $0102_1E2F ==> mem_bitswap(bb). -: $8040_78F4 SEE ALSO: mem_byteswap, mem_btest #---------------------------------------------------------- ?mem_byteswap mem_byteswap(var b: byte_string; wordlen: integer): byte_string; The byte_string is subdivided in groups of wordlen bytes each. Within each group, the bytes are swapped from most significant <--> least significant. The modified byte_string is returned. Example: ==> bb := $AABBCCDDEE. -: $AABB_CCDD_EE ==> mem_byteswap(bb,2). -: $BBAA_DDCC_EE SEE ALSO: mem_bitswap, mem_shift #--------------------------------------------------------------- ?array ?of array of Type The array is a structured data type, consisting of finite sequences of components of a given (but arbitrary) data type Type. Array literals are given by a comma separated list of its components. The list is enclosed between a pair of parentheses ( and ), for example vec := (37, 41, -9). However, for arrays of length 1, braces must be used. vec1 := {37}. The expression (37) is interpreted by ARIBAS as the number 37. One may use braces instead of parentheses also for arrays of length > 1. The components of an array vec can be accessed as vec[i] where 0 <= i < length(vec). SEE ALSO: subarray, vector_ops, alloc, max_arraysize #--------------------------------------------------------------- ?subarray Besides accessing single components of an array, one can also access whole subarrays. If vec is an array, then vec[n1..n2] denotes the subarray consisting of all components vec[i] with n1 <= i <= n2. Example: ==> vec := (1,2,3,4,5,6,7,8,9,10). -: (1, 2, 3, 4, 5, 6, 7, 8, 9, 10) ==> vec[2..6]. -: (3, 4, 5, 6, 7) The upper bound may be omitted: vec[n1..] is equivalent to vec[n1..length(vec)-1]. Subarrays may also appear at the left hand side of assignments and thus allow the simultaneous modification of several components. SEE ALSO: array #--------------------------------------------------------------- ?vector_ops -vec, vec1 + vec2, vec1 - vec2 lambda * vec, vec * lambda, vec/lambda vec, vec1, vec2 may be of data type array of integer or array of real and lambda of data type integer or real. Calculate the negative of vec, sum and difference of vectors vec1 and vec2, resp. the product of the vector vec by the scalar lambda or 1/lambda. vec1 and vec2 need not have the same length; the shorter one is implicitely expanded to the greater length by appending zeroes. Examples: ==> -(1,1) + pi*(1,2,3). -: (2.14159265, 5.28318531, 9.42477796) ==> (100, 200, 300, 400)/1.95583. -: (51.1291881, 102.258376, 153.387564, 204.516752) vec div N, vec mod N Here vec must be an array of integers and N an integer /= 0. The operators div resp. mod are applied componentwise to the vector vec. Example: ==> (1000, 1100, 1200) mod 12. -: (4, 8, 0) SEE ALSO: sum, product, gcd, max, min #--------------------------------------------------------------- ?max_arraysize max_arraysize(): integer; In the present version of ARIBAS, lengths of arrays cannot be very large. The function max_arraysize returns the maximal admissible length. Typically, under UNIX, this value is about 64000, under MSDOS about 12000 or 16000. The maximal admissible length for strings and byte_strings is min(4*max_arraysize(), 2**16-1). SEE ALSO: array, alloc #--------------------------------------------------------------- ?sort sort(var vec: array of integer): array of integer; sort(var vec: array of real): array of real; sort(var vec: array of string): array of string; The array vec, which is passed to the function sort as a variable argument, is sorted in non-decreasing order (for strings, the lexicographic order with respect to the ASCII-codes of characters is used). The sorted array is returned. sort(var vec: array of Type; compfun: function): array of Type; The function sort may be given as a second optional argument a comparison function compfun(x,y: Type): integer; which must be a function of two arguments of the same data type as the components of the array. The relation defined by compfun(x,y) <= 0 must be transitive. Then vec is sorted in non-decreasing order, where x <= y is defined by compfun(x,y) <= 0. SEE ALSO: binsearch #--------------------------------------------------------------- ?binsearch binsearch(ele: ; var vec: array of [; compfun: function]): integer; The array vec must be a sorted array of elements of type . The function searches in this array for an occurrence of the element ele and returns its position (zero-based). If ele is not found, -1 is returned. The third argument of binsearch is a comparison function compfun(x,y: ): integer; which must be a function of two arguments of the same data type as the components of the array (see function sort). If vec is an array of integers, characters or strings, then the comparison function may be omitted. In this case the natural order (numerical resp. alphabetical) is assumed. SEE ALSO: sort #--------------------------------------------------------------- ?alloc alloc(Arraytype, Len [,Ele]): Arraytype; Arraytype must be one of the symbols array, string, byte_string. The function generates an array (resp. a string, a byte_string) of length Len, where all components are equal to Ele. If the argument Ele is not given, a default element is used. This default element is 0 for arrays, the space character ' ' for strings, and the zero byte for byte_strings. Examples: ==> alloc(array,10). -: (0, 0, 0, 0, 0, 0, 0, 0, 0, 0) ==> alloc(string,5,'A'). -: "AAAAA" ==> alloc(byte_string,5,127). -: $7F7F_7F7F_7F #---------------------------------------------------------- ?realloc realloc(var vec: ; len: integer [; ele]): The variable argument vec must be an array, a string or a byte_string. If the integer len is bigger than the length of vec, the function increases the length of vec to len by appending components of value ele at the end. If ele is not given, default values are used. The new array (resp. string}, byte_string) is returned and also placed in the variable vec. If len is equal to the length of vec, then vec remains unchanged. If len is smaller than the length of vec, then vec is truncated to this smaller length. Examples: ==> vec := (17,4,31). -: (17, 4, 31) ==> realloc(vec,5,53). -: (17, 4, 31, 53, 53) ==> bb := $AABB. -: $AABB ==> realloc(bb,10). -: $AABB_0000_0000_0000_0000 ==> s := "abcde". -: "abcde" ==> realloc(s,3). -: "abc" #---------------------------------------------------------- ?stack stack Builtin data type of ARIBAS. There are no stack literals. One can generate stacks by variable declarations. For example, the following top level declaration var st: stack; end. generates an empty stack. Afterwards, one can put elements onto the stack using stack_push. SEE ALSO: stack_push, stack_pop, stack_top, stack_reset, stack_empty stack2array #-------------------------------------------------------------------- ?stack_push stack_push(st: stack; ele: Type): Type; Puts an element ele (of arbitrary data type Type) on top of the stack st. The length of the stack is increased by 1. The return value of the function is ele. SEE ALSO: stack_arraypush, stack_pop, stack #----------------------------------------------------------------- ?stack_arraypush stack_arraypush(st: stack; vec: array of [; direction: integer]): integer; Pushes the components of the array vec onto the stack st. If the argument direction is positive or omitted, the order is from beginning to the end of vec. If direction is negative, the pushing occurs in reverse order. Return value is the number of elements pushed on st (= the length of vec). Examples: ==> var st: stack; end. -: var ==> vec := (1,2,3,4,5). -: (1, 2, 3, 4, 5) ==> stack_arraypush(st,vec,-1). -: 5 ==> vec1 := stack2array(st). -: (5, 4, 3, 2, 1) SEE ALSO: stack_push #----------------------------------------------------------------- ?stack_pop stack_pop(st: stack): Type; The stack st must be non-empty. The function removes the top element of st and returns it. The length of the stack is decreased by 1. SEE ALSO: stack_top, stack_push, stack #----------------------------------------------------------------- ?stack_top stack_top(st: stack): Type; Returns the top element of the stack st; the stack itself is not altered. SEE ALSO: stack_pop, stack #----------------------------------------------------------------- ?stack_reset stack_reset(st: stack): integer; Removes all elements from the stack st. There remains an empty stack. The function returns 0. SEE ALSO: stack_empty, stack #----------------------------------------------------------------- ?stack_empty stack_empty(st: stack): boolean; Tests if the stack st is empty. SEE ALSO: stack_reset, stack #----------------------------------------------------------------- ?stack2array stack2array(st: stack): array of Type; Returns an array of length equal to length(st) whose components are the elements lying on the stack. The element at the bottom of the stack becomes the component of index 0. After execution of this function, the stack st is empty. It is in the responsibility of the programmer to ensure that all elements have the correct data type. SEE ALSO: stack2string, stack_pop, stack #----------------------------------------------------------------- ?stack2string stack2string(st: stack): string; The elements on the stack st, which are strings or characters, are concatenated to a string. This string is returned. Elements of other data types on the stack are ignored. After execution of this function, the stack st is empty. Example: ==> var st: stack; end. -: var ==> stack_push(st,"stack"). -: "stack" ==> stack_push(st,pi). -: 3.14159265 ==> stack_push(st,'_'). -: '_' ==> stack_push(st,"push"). -: "push" ==> stack2string(st). -: "stack_push" SEE ALSO: stack2array, concat #----------------------------------------------------------------- ?transcript transcript([fnam: string]): boolean; Opens a log file with name fnam. The extension .log is appended automatically to fnam, if fnam has no extension. If no argument is given to transcript, "aribas.log" is used by default. For example, ==> transcript("a1"). -: true opens a file a1.log (if it exists already, its previous content is lost). The effect of transcript is that all subsequent interaction between the user and ARIBAS is transcribed to the log file until the log file is closed again with the command ==> transcript(0). The end of an ARIBAS session closes the log file automatically. #----------------------------------------------------------------- ?help help(Topic) Gives a short online help on Topic. For Topic one can use most symbols of the list returned by the command symbols(aribas). For example, ==> help(factor16). gives a short description of the builtin function factor16. Often, the help ends with a list of cross references (introduced by `SEE ALSO:'). Calling help for the topics listed there gives you further information. SEE ALSO: symbols #----------------------------------------------------------------- ?length length(x: array): integer; length(x: string): integer; length(x: byte_string): integer; Returns the length of the array (resp. string, byte_string) x length(st: stack): integer; Returns the length of the stack st, i.e. the number of elements (of arbitrary data type) which lie on the stack. length(f: file): integer; f must be a file opened for reading. Then the function returns the length of the file in bytes. SEE ALSO: byte_length, bit_length #-------------------------------------------------------------------- ?readln readln([f: file;] var arg1,...,argn): integer; Reads a line from file f, which must have been opened for reading. (If the file argument is not supplied, stdin is assumed, i.e. readln reads from the terminal.) The arguments arg1,...,argn must be of type integer, real, char or string. (A string variable consumes all characters until the end of line.) The return value of readln is the number of successfully read items. If the end of file is already reached before the call of readln, -1 is returned. For example, assume that x is an integer variable, c1, c2 are character variables and s is a string variable. If the current line in the file f is 1234 56 ab (where the line ends immediately after the character b), then readln(f,c1,x,c2,s) will return 4 and the variables will contain the following values: c1 = '1', x = 234, c2 = ' ', s = "56 ab". If the same line is read with readln(f,s,x,c1,c2), then the return value is 1, the variable s contains the string "1234 56 ab", and x, c1, c2 are undefined. readln(f) simply returns 0 and advances the file position to the beginning of the next line. SEE ALSO: open_read, writeln, read_byte, read_block #-------------------------------------------------------------------- ?write ?writeln write([f: file;] arg1,...,argn): integer; writeln([f: file;] arg1,...,argn): integer; Writes the arguments arg1,...,argn (which may have any data type) into a text file f, which must have been opened for writing. The function writeln adds a linefeed to the output. (If the file argument is not supplied, stdout is assumed, i.e. the functions write to the terminal.) Return value is the number of written arguments or -1 in case of error. SEE ALSO: open_write, open_append, flush #-------------------------------------------------------------------- ?flush flush([f: file]); If f is an output file (default f = stdout) to which write operations have been performed, but some of the data are still being held in a buffer, then flush writes all data actually to the file. SEE ALSO: write, write_byte #-------------------------------------------------------------------- ?stdout ?stdin ?stderr stdout stdin stderr Predefined file variables of ARIBAS, usually (if not redirected) connected to the terminal. The functions write and writeln, if not given a file argument, use stdout by default; the function readln, if not given a file argument, reads from stdin. Error messages of ARIBAS go to stderr. SEE ALSO: write, writeln, readln, flush #-------------------------------------------------------------------- ?file file Data type in ARIBAS. To access an external file, which is stored under a certain name somewhere on the hard disk or a floppy disk for read or write operations in ARIBAS, it must first be opened and assigned to a file variable. This is done with the functions open_read, open_append or open_write. SEE ALSO: open_read, open_append, open_write, readln, writeln, binary, read_byte, write_byte #-------------------------------------------------------------------- ?binary BINARY FILES In ARIBAS, files are text files by default. However, files can also be opened in binary mode for reading and writing using the functions open_write, open_read, open_append. In this case, a third argument, consisting of the keyword binary, must be given. Example: ==> open_read(f,"BIN.DAT",binary). This opens a file with name "BIN.DAT", which is supposed to exist, for reading in binary mode. For binary files there are the read operations read_byte and read_block and the write operations write_byte and write_block. The functions rewind and length may also be applied to binary files, which have been opened for reading. SEE ALSO: read_byte, read_block, write_byte, write_block, set_filepos open_read, open_write, open_append #-------------------------------------------------------------------- ?set_filepos set_filepos(f: file; pos: integer): integer; f must be a binary file, opened for reading and pos must be an integer satisfying 0 <= pos < length(f). Then set_filepos sets the position for the next read operation at pos bytes from the beginning of the file. If pos is not in the admissible range, no action is taken. Return value is the file position after execution of set_filepos. SEE ALSO: get_filepos, binary #-------------------------------------------------------------------- ?get_filepos get_filepos(f: file): integer; f must be a binary file, opened for reading. The function returns the current file position. SEE ALSO: set_filepos, binary #-------------------------------------------------------------------- ?read_byte read_byte(f: file): integer; Reads one byte at the current file position from a binary file opened for reading and increases the file position by 1. Return value is the read byte (an integer in the range 0 <= x < 256). If the file position is already end-of-file when read_byte is called, then -1 is returned and the file position remains unchanged. SEE ALSO: read_block, write_byte, binary #-------------------------------------------------------------------- ?read_block read_block(f: file; var block: byte_string; len: integer): integer; f must be a binary file opened for reading. The argument block must be a byte_string variable or a subarray of a byte_string with an actual length >= len. Then read_block reads len bytes from the file f (starting at the current file position) and stores them into the first len components of block. If the end-of-file is reached prematurely, the reading operation is stopped and only the bytes read so far are stored in block. Return value of read_block is the number of actually read bytes. The file position is advanced by this value. SEE ALSO: read_byte, write_block, binary #-------------------------------------------------------------------- ?write_byte write_byte(f: file; x: integer): integer: Writes one byte (given by the integer x in the range 0 <= x < 256) into a binary file f opened for writing (using open_write or open_append). Instead of an integer x one can use also a character. Return value in case of success is the written byte. In case of error, -1 is returned. SEE ALSO: write_block, read_byte, binary #-------------------------------------------------------------------- ?write_block write_block(f: file; var block: byte_string; len: integer): integer; f must be a binary file opened for writing. The argument block must be a byte_string variable or a subarray of a byte_string with an actual length >= len. Then write_block writes the first len bytes from block into the file f. Return value of write_block is the number of successfully written bytes. If no error occurs, this number equals len. SEE ALSO: write_byte, read_block, binary #-------------------------------------------------------------------- ?open_write open_write(var f: file; fnam: string): boolean; Opens a file with name fnam for write operations and sets the file variable f. (This file variable is needed for the write operations.) If a file with name fnam does not exist, it is created. Return value: true if the file has been succesfully opened, and false, if an error occurs. In case of success, the variable f is filled with a file descriptor value that must be used for subsequent write operations to the file. CAUTION: If a file with name fnam exists already, its previous content is overwritten and will be lost. SEE ALSO: write, open_append, binary #-------------------------------------------------------------------- ?open_append open_append(var f: file; fnam: string): boolean; Opens a file with name fnam for write operations and sets the file variable f. (This file variable is needed for the write operations.) If a file with name fnam does not exist, it is created. If the file exists already, the previous content is preserved and the new write operations are at the end of the file. Return value: true if the file has been succesfully opened, and false, if an error occurs. In case of success, the variable f is filled with a file descriptor value that must be used for subsequent write operations to the file. SEE ALSO: write, open_write, binary #-------------------------------------------------------------------- ?open_read open_read(var f: file; fnam: string): boolean; Opens an existing file with name fnam for sequential reading. Return value: true if the file has been succesfully opened, and false, if an error occurs. In case of success, the variable f is filled with a file descriptor value that must be used for subsequent read operations from the file. SEE ALSO: readln, open_write, binary #-------------------------------------------------------------------- ?rewind rewind(var f: file): boolean; If f is a file which has been opened for reading and from which some data have already been read, rewind(f) resets the file position for the the next read operation to the beginning of the file. Return value: true if successful, else false. SEE ALSO: set_filepos #-------------------------------------------------------------------- ?close close(f: file): boolean; Closes a file f which has been opened before. SEE ALSO: open_write, open_append, open_read #-------------------------------------------------------------------- ?load load(fnam: string): boolean; fnam must be the name of a text file with ARIBAS source code, the extension .ari may be omitted. Then load reads this file and executes all commands and function definitions in the file as if they had been input directly at the ARIBAS prompt. Returns true, if the load operation was successful. In case of error, an error message is written, specifying a line number, where the error was detected (actually the error might be in some previous line). load(fnam,0). With a second argument 0 the function load works in quiet mode, the messages to terminal are suppressed. #-------------------------------------------------------------------- ?system system(command: string): integer; The string command is handed to the command interpreter (resp. shell) of the system for execution. Return value is an error code or 0. For example, under MS-DOS, ==> system("dir"). generates a listing of the current directory. Under UNIX, you can use ==> system("ls -l"). for the same purpose. #----------------------------------------------------------------- ?getenv getenv(name: string): string; Returns the value of the environment variable name or the empty string, if this variable is not defined. Example: Under UNIX, ==> getenv("HOME"). returns the name of the home directory of the current user. #----------------------------------------------------------------- ?set_workdir set_workdir(path: string): string; Sets the current working directory to the one given by path. This can be either an absolute or a relative path. Return value is the new path. If the path does not exist, or ARIBAS is unable to open it, then the old working directory remains unchanged and the empty string is returned. Example: ==> set_workdir("D:\aribas\work"). -: "D:\aribas\work" (This example supposes that the directory "D:\aribas\work" exists.) SEE ALSO: get_workdir #----------------------------------------------------------------- ?get_workdir get_workdir(): string; Retrieves the current working directory. SEE ALSO: set_workdir #----------------------------------------------------------------- ?exit exit The command exit stops ARIBAS and returns to the shell or command interpreter from where ARIBAS was called. SEE ALSO: halt #----------------------------------------------------------------- ?halt halt([retcode: integer]): integer; A call to halt causes an immediate stop of the current program and a return to top level (even if halt occurs in a deeply nested function call). The return value is the optional argument retcode, which must be a 16-bit integer (default value 0). The function halt is mainly used to recover from serious errors. Note: In contrast to exit, halt does not stop ARIBAS, but returns to the ARIBAS prompt. SEE ALSO: exit #----------------------------------------------------------------- ?memavail memavail(): integer; Writes some memory statistics to the screen and returns the free space (measured in KB) on the ARIBAS heap. Since ARIBAS possesses a garbage collector using the half space method, the ARIBAS heap is subdivided into two equal parts. One part is active, memory requirements are satisfied from this part. The size of the two parts and the space still available in the active part is reported. If the memory in the active part is exhausted, the garbage collector is called automatically. The total number of garbage collections since the beginning of the current ARIBAS session is also given. The names of user defined functions and variables are stored by ARIBAS in a symbol table. The space still available for this purpose is also reported. One can suppress all messages by calling memavail with the argument 0. Example: ==> memavail(0). -: 82 SEE ALSO: gc #----------------------------------------------------------------- ?gc gc(): integer; Forces a garbage collection and returns the new amount of free memory (in KB) on the ARIBAS heap. The function outputs the same messages as the function memavail. A quiet version is gc(0). This is useful for example, if one wants to call some procedure only if a certain minimal amount of memory is available, as in the following code if gc(0) < 64 then writeln("not enough memory for procedure foo"); else foo(...); ... end; SEE ALSO: memavail #----------------------------------------------------------------- ?timer timer(): integer; Returns the number of milliseconds elapsed since a certain starting point dependent on the current computer session. (The precision is system dependent.) This can be used for example to measure the time needed to execute a certain function. Example: ==> t := timer(); x := isqrt(2*10**2000); timer() - t. -: 88 In the above example, which was done with the LINUX version of ARIBAS on a computer with a 80486 processor, 33MHz, the square root of 2 was calculated with a precision of 1000 decimal places in 88 milliseconds. SEE ALSO: gmtime #-------------------------------------------------------------------- ?gmtime gmtime(): string; Returns Greenwich Mean Time as a string in the format "YYYY:MM:DD:hh:mm:ss" (year, month, day, hour, minutes, seconds). You can use the function string_split to retrieve the components of this string and use it to write your own custumized time function. Example: ==> gmtime(). -: "2003:06:09:08:26:20" ==> tt := string_split(_,":"). -: ("2003", "06", "09", "08", "26", "20") ==> t0 := alloc(array,6); for k := 0 to 5 do t0[k] := atoi(tt[k]); end; t0. -: (2003, 6, 9, 8, 26, 20) gmtime(0): integer; If gmtime is called with the argument 0, then it returns the number of seconds passed since Jan. 1, 2000, 0:00 h GMT. SEE ALSO: timer #-------------------------------------------------------------------- ?aribas ?user ?symbols symbols(aribas). Returns a list of ARIBAS keywords and builtin functions. The argument aribas has to be given as it stands (lower case, without quotes). symbols(user). Returns a list of currently user defined variables and functions. SEE ALSO: make_unbound #------------------------------------------------------------ ?make_unbound make_unbound(Sym): boolean; Sym must be a user defined symbol denoting a variable, constant or function. (The command symbols(user) returns a list of those symbols). make_unbound removes the binding of Sym. This can be useful if one wants to recover memory used for variables (holding e.g. big integers or long arrays) which are no longer needed. Builtin functions cannot be made unbound. Return value is true in case of success, false in case of failure. SEE ALSO: symbols #------------------------------------------------------------ ?version version(): integer; Writes the version number and the architecture, for which ARIBAS was compiled, to the terminal screen. Returns an integer, which is 100*(major version no) + (minor version no). Example: ==> version(). ARIBAS Version 1.01, Sep. 1996 (MS-DOS 386) -: 101 With the optional argument 0, the message to the screen is suppressed. Example: ==> version(0). -: 101 #------------------------------------------------------------ ?var var Variable declarations: In ARIBAS, variables may be declared at top level or inside function definitions. For example, the following is a top level declaration of an integer x and an array vec of length 100. ==> var x: integer; vec: array[100]; end. -: var Inside function definitions, the end of the variable declaration is marked by the symbol begin which denotes the start of the function code. Note: At top level, variable declarations are not obligatory since variables can be created by assignments. However inside function definitions all used variables have to be declared. SEE ALSO: procedure, const, external, begin #------------------------------------------------------------ ?const const Constant declarations: In ARIBAS, constants may be declared at top level or inside function definitions. For example, the following is a top level declaration of an integer constant Bound with value 2**16 and a constant array Weekdays of strings; ==> const Bound = 2**16; Weekdays = ("SU", "MO", "TU", "WE", "TH", "FR", "SA"); end. -: const Inside function definitions, the end of the constant declaration is not marked by the symbol end but either by the symbol var (begin of a variable declaration) or by the symbol begin (start of the function code). SEE ALSO: var #------------------------------------------------------------ ?external external In ARIBAS, all global variables which are used inside a function definition, have to be declared as external. The external declaration comes first, before the constant and variable declaration. As an example, suppose that there exists a global integer variable Counter. This can be used in the following way to count how often the function foo is called: function foo(vec: array of real): real; external Counter: integer; var len: integer; begin inc(Counter); len := length(vec); return product(vec)**(1/len); end. SEE ALSO: procedure, function, var #------------------------------------------------------------ ?type type The user may define her own types in top level type declarations. For example, the following type declaration ==> type vector = array[3] of real; item = record key: integer; name: string; data: byte_string; end; end. -: type defines a type vector denoting an array of 3 reals and a type item which denotes a record with 3 fields (of type integer, string and byte_string respectively). After such a type declaration (which can occur only at top level), the newly defined types can be used at top level and inside functions in the same way as the builtin data types of ARIBAS. SEE ALSO: record #------------------------------------------------------------ ?record A record is a structured data type consisting of several components (called fields) which may have different types. Records can be defined in (top level) type declarations, for example type item = record key: integer; data: byte_string[8]; end; end; declares a type item which is a record with two fields, named key and data. After this type declaration a variable declaration var xx: item; end; creates a record of type item. The fields of this record are then xx.key and xx.data. The first is an integer and the latter a byte_string of length 8, so that an assignment of the following form is possible: xx.data[5] := 127 SEE ALSO: type, pointer #------------------------------------------------------------ ?pointer pointer to ; The pointer syntax in ARIBAS is as in Modula-2, however only pointers to records exist. Pointers can be used to construct dynamical data types. For example, a linked list of strings can be defined using the following type declaration. type list = pointer to item; item = record name: string; next: list; end; end; If after this type declaration a pointer variable of type list is defined in a variable declaration like var LL: list; end; then LL does not yet point to a record of type item, but is initialized with the value nil. In order to make LL point to an actual record, the procedure new has to be used. SEE ALSO: record, new, nil #------------------------------------------------------------ ?nil nil Constant which can be assigned to any pointer variable. In ARIBAS all pointer variables are initialized with the value nil. To make a pointer variable point to an actual record, the procedure new has to be used. SEE ALSO: pointer, new #------------------------------------------------------------ ?new new(var ptr: pointer to ): ; If ptr is a variable of type pointer to a certain record type, then new(ptr) creates a new record of that type and makes ptr point to this record. For example, after the variable declaration var ptr: pointer to record x,y,w,h: integer; end; end; ptr has the value nil. Calling ==> new(ptr). -: &(0, 0, 0, 0) produces a record with 4 integer fields ptr^.x, ptr^.y, ptr^.w and ptr^.h, which can also be used as left hand sides in assignments, for example ==> ptr^.x := ptr^.y := 10; ptr^.w := 512; ptr^.h := 360. -: 360 ==> ptr^. -: &(10, 10, 512, 360) SEE ALSO: pointer, record, nil #------------------------------------------------------------ ?function data type function User defined functions and builtin functions (with the exception of write, writeln) can be assigned to variables and used as arguments of other functions. Example: ==> F := (cos,sin,tan). -: (cos, sin, tan) ==> for i := 0 to length(F)-1 do fun := F[i]; writeln(fun(pi/6)); end. 0.866025404 0.500000000 0.577350269 function (and it's synonym procedure) is also the keyword introducing a function definition, see description under procedure. SEE ALSO: procedure #------------------------------------------------------------ ?procedure function, procedure The keyword function (or it's synonym procedure) introduces a function definition, which has the form function (): ; begin end; The external, constant and variable declarations may also be absent. Example: function foo(x,n: integer): integer; var i: integer; begin for i := x+1 to n do x := x*i; end; return x; end; SEE ALSO: external, const, var, begin, return, function #------------------------------------------------------------ ?return return ; A return statement can appear in the body of a function definition (this body is delimited by the symbols begin and end). must be an expression evaluating to an object of data type equal to the result type of the function. If during a function call the evaluation reaches the return statement, the value of is returned immediately as the result of the function call. In ARIBAS, the result type of a function may also be a structured type like an array. Example: function foo(x: integer): array[3]; var x2: integer; begin x2 := x*x; return (x,x2,x2*x); end; SEE ALSO: procedure, function, begin #------------------------------------------------------------ ?begin ?end begin end; Inside a function definition the keyword begin indicates the start of the function body. The function body and at the same time the function definition ends with the keyword end. Example: function fac(n: integer): integer; var x, i: integer; begin x := 1; for i := 2 to n do x := x*i; end; return x; end; SEE ALSO: procedure, function #------------------------------------------------------------ ?ARGV ARGV: array of string; If you call aribas with command line arguments, aribas [options] ... where is a file with ARIBAS source code, then ARIBAS will load this file and the vector ARGV will contain the elements , , ..., as strings. Suppose for example you have a file startup.ari in the current directory and call aribas -q startup 4536 eisenstein then ARGV = ("startup", "4536", "eisenstein"). If you need some arguments as numbers and not as strings, you can transform them by atoi (or atof); in our example x := atoi(ARGV[1]) will do it. The length of the vector ARGV can be determined by length(ARGV). SEE ALSO: atoi, atof, length #------------------------------------------------------------ ?_ ?__ ?___ - -- --- The symbols _, __ and ___ are pseudo variables which contain the three most recent results. For example, ==> 2**10. -: 1024 ==> _**2. -: 1048576 ==> _*__. -: 1073741824 ==> ___*__*_. -: 1152_92150_46068_46976 #------------------------------------------------------------ (************************* EOF *****************************) aribas165b/src/aritaux.c0000644000076600000240000006627614660570650014230 0ustar ottostaff/****************************************************************/ /* file aritaux.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** aritaux.c ** auxiliary procedures for arithmetic ** ** date of last change ** 1994-12-31 ** 2000-12-30: multiprec floats ** 2002-02-16: changesign ** 2002-04-21: chkintnz ** 2018-09-13 fixed minor errors and compiler warnings ** (thanks to D. Trebbien for testing) */ #include "common.h" PUBLIC int setfltprec (int prec); PUBLIC int deffltprec (void); PUBLIC int maxfltprec (void); PUBLIC int fltpreccode (int prec); PUBLIC int fltprec (int type); PUBLIC int refnumtrunc (int prec, truc *ptr, numdata *nptr); PUBLIC int getnumtrunc (int prec, truc *ptr, numdata *nptr); PUBLIC int getnumalign (int prec, truc *ptr, numdata *nptr); PUBLIC int alignfloat (int prec, numdata *nptr); PUBLIC int alignfix (int prec, numdata *nptr); PUBLIC void adjustoffs (numdata *npt1, numdata *npt2); PUBLIC int normfloat (int prec, numdata *nptr); PUBLIC int multtrunc (int prec, numdata *npt1, numdata *npt2, word2 *hilf); PUBLIC int divtrunc (int prec, numdata *npt1, numdata *npt2, word2 *hilf); PUBLIC int pwrtrunc (int prec, unsigned base, unsigned a, numdata *nptr, word2 *hilf); PUBLIC int float2bcd (int places, truc *p, numdata *nptr, word2 *hilf); PUBLIC int roundbcd (int prec, numdata *nptr); PUBLIC int flodec2bin (int prec, numdata *nptr, word2 *hilf); PUBLIC void int2numdat (int x, numdata *nptr); PUBLIC void cpynumdat (numdata *npt1, numdata *npt2); PUBLIC int numposneg (truc *ptr); PUBLIC truc wipesign (truc *ptr); PUBLIC truc changesign (truc *ptr); PUBLIC long intretr (truc *ptr); PUBLIC int bigref (truc *ptr, word2 **xp, int *sp); PUBLIC int bigretr (truc *ptr, word2 *x, int *sp); PUBLIC int twocretr (truc *ptr, word2 *x); PUBLIC int and2arr (word2 *x, int n, word2 *y, int m); PUBLIC int or2arr (word2 *x, int n, word2 *y, int m); PUBLIC int xor2arr (word2 *x, int n, word2 *y, int m); PUBLIC int xorbitvec (word2 *x, int n, word2 *y, int m); PUBLIC long bit_length (word2 *x, int n); PUBLIC int chkintnz (truc sym, truc *ptr); PUBLIC int chkints (truc sym, truc *argptr, int n); PUBLIC int chkint (truc sym, truc *ptr); PUBLIC int chkintt (truc sym, truc *ptr); PUBLIC int chknums (truc sym, truc *argptr, int n); PUBLIC int chknum (truc sym, truc *ptr); PUBLIC int chkintvec (truc sym, truc *vptr); PUBLIC int chknumvec (truc sym, truc *vptr); PRIVATE long decdigs (numdata *nptr); PRIVATE int malzehnhoch (int prec, numdata *nptr, long d, word2 *hilf); PRIVATE int twocadjust (word2 *x, int n); PUBLIC int FltPrec[20] = {2, 4, 8, 12, 16, 24, 32, 40, 48, 56, 64, 80, 96, 112, 128, 160, 192, 224, 256, 320}; #ifdef FPREC_HIGH #define MAXFLTLEVEL 19 #else #define MAXFLTLEVEL 10 #endif PUBLIC int MaxFltLevel = MAXFLTLEVEL; PRIVATE int floatprec = 2; /*------------------------------------------------------------*/ PUBLIC int setfltprec(prec) int prec; { int k; k = 0; while((k < MaxFltLevel) && (prec > FltPrec[k])) k++; floatprec = FltPrec[k]; return(floatprec); } /*-------------------------------------------------------------*/ PUBLIC int fltpreccode(prec) int prec; { int k; k = 0; while((k < MaxFltLevel) && (prec > FltPrec[k])) k++; return(k); } /*-------------------------------------------------------------*/ PUBLIC int maxfltprec() { return(FltPrec[MaxFltLevel]); } /*-------------------------------------------------------------*/ PUBLIC int deffltprec() { return(floatprec); } /*------------------------------------------------------------*/ PUBLIC int fltprec(type) int type; { int k; if(type >= fFLTOBJ) { k = (type & PRECMASK) >> 1; return FltPrec[k]; } else return(floatprec); } /*------------------------------------------------------------*/ /* ** Erzeugt Referenz auf Zahl in *p mit prec 16-bit-Stellen (ohne Kopie) ** Fuer die Zahl 0 wird nptr->len = 0 und nptr->expo = MOSTNEGEX */ PUBLIC int refnumtrunc(prec,p,nptr) int prec; /* should be >= 2 */ truc *p; numdata *nptr; { static word2 ddd[2]; struct bigcell *big; struct floatcell *fl; long ex; int len, diff, pcode; int flg = *FLAGPTR(p); if(flg == fFIXNUM) { if(!*WORD2PTR(p)) goto zeroexit; nptr->digits = WORD2PTR(p); nptr->sign = *SIGNPTR(p); nptr->len = 1; nptr->expo = 0; } else if(flg == fBIGNUM) { big = (struct bigcell *)TAddress(p); nptr->sign = big->signum; len = big->len; ex = diff = (len > prec ? len - prec : 0); nptr->digits = &(big->digi0) + diff; nptr->len = len - diff; nptr->expo = (ex << 4); } else if(flg >= fFLTOBJ) { if(flg & FLTZEROBIT) goto zeroexit; pcode = (flg & PRECMASK); len = FltPrec[pcode>>1]; fl = (struct floatcell *)TAddress(p); nptr->sign = (fl->signum & FSIGNBIT ? MINUSBYTE : 0); diff = (len > prec ? len - prec : 0); nptr->digits = &(fl->digi0) + diff; nptr->len = len - diff; ex = fl->expo; if(flg >= fHUGEFLOAT) { ex <<= 7; ex += (fl->signum & HUGEMASK); } nptr->expo = ex + (diff << 4); } else { error(voidsym,err_case,voidsym); return(0); } return(nptr->len); zeroexit: nptr->digits = ddd; nptr->len = 0; nptr->sign = 0; nptr->expo = MOSTNEGEX; return(0); } /*------------------------------------------------------------------*/ /* ** holt Zahl aus *ptr nach *nptr mit prec 16-bit-Stellen (mit Kopie) */ PUBLIC int getnumtrunc(prec,ptr,nptr) int prec; truc *ptr; numdata *nptr; { int len; word2 *saveptr; saveptr = nptr->digits; len = refnumtrunc(prec,ptr,nptr); cpyarr(nptr->digits,len,saveptr); nptr->digits = saveptr; return(len); } /*------------------------------------------------------------------*/ /* ** holt Zahl aus *p und normalisiert sie */ PUBLIC int getnumalign(prec,p,nptr) int prec; truc *p; numdata *nptr; { getnumtrunc(prec,p,nptr); return(alignfloat(prec,nptr)); } /*-------------------------------------------------------------------*/ /* ** Die in nptr gegebene Zahl wird so normalisiert, dass nptr->expo ** durch 16 teilbar wird. ** Es werden genau prec 16-bit-Stellen benuetzt, falls Zahl /= 0 ** Fuer die Zahl 0 ist der Rueckgabewert 0 */ PUBLIC int alignfloat(prec,nptr) int prec; numdata *nptr; { int len, b; long sh; len = nptr->len; if(len == 0) return(0); b = nptr->expo & 0xF; /* b != 0 only for floats */ sh = prec - len; sh <<= 4; sh -= (b ? 16-b : 0); nptr->expo -= sh; nptr->len = lshiftarr(nptr->digits,len,sh); return(nptr->len); /* nptr->len = prec */ } /*-----------------------------------------------------------------*/ /* ** Die Zahl in nptr wird so normalisiert, dass ** nptr->expo gleich -(prec<<4) wird. ** Falls aber nptr->len groesser als 2*prec wuerde, ** wird nptr unveraendert gelassen und aERROR zurueckgegeben. ** Sonst ist der Rueckgabewert nptr->len */ PUBLIC int alignfix(prec,nptr) int prec; numdata *nptr; { int len; long sh; if(!(len = nptr->len)) return(0); sh = nptr->expo; if(len + (sh>>4) > prec) return(aERROR); sh += prec<<4; nptr->expo -= sh; nptr->len = lshiftarr(nptr->digits,len,sh); return(nptr->len); } /*-------------------------------------------------------------------*/ /* ** Die in npt1 und npt2 gegebenen Zahlen werden so normalisiert, ** dass beide expos gleich werden ** Es erfolgt ein Rechtsshift auf npt1->digits oder npt2->digits ** Nur npt1->expo wird auf den korrekten Wert gesetzt ** Es wird vorausgesetzt, dass beide expos durch 16 teilbar sind */ PUBLIC void adjustoffs(npt1,npt2) numdata *npt1, *npt2; { int diff; if(npt1->len == 0) npt1->expo = npt2->expo; else if(npt2->len == 0) ; else if((diff = (npt1->expo - npt2->expo) >> 4) > 0) { if(diff >= npt2->len) npt2->len = 0; else { npt2->len -= diff; cpyarr(npt2->digits+diff,npt2->len,npt2->digits); } } else if(diff < 0) { npt1->expo = npt2->expo; if(-diff >= npt1->len) npt1->len = 0; else { npt1->len += diff; cpyarr(npt1->digits-diff,npt1->len,npt1->digits); } } } /*------------------------------------------------------------------*/ /* ** Die durch nptr gegebene float-Zahl wird normalisiert, so dass ** die mantisse genau (prec*16) Bits lang wird. ** nptr->expo wird der Exponent bzgl. Basis 2 ** Rueckgabewert: 0 fuer die Zahl 0, sonst prec ** !!! arbeitet destruktiv auf nptr !!! */ PUBLIC int normfloat(prec,nptr) int prec; numdata *nptr; { int len; long sh; len = nptr->len; if(len == 0) { nptr->sign = 0; nptr->expo = MOSTNEGEX; return(0); } nptr->len = prec; sh = prec - len + 1; sh <<= 4; sh -= bitlen(nptr->digits[len-1]); lshiftarr(nptr->digits,len,sh); nptr->expo -= sh; return(prec); } /*-------------------------------------------------------------------*/ /* ** Die durch npt1 gegebene Zahl wird mit der durch npt2 gegebenen ** Zahl multipliziert. Produkt in npt1 ** Die Laenge des Produkts wird auf <= prec 16-bit-Stellen gekuerzt ** Platz hilf muss 3*prec + 4 lang sein */ PUBLIC int multtrunc(prec,npt1,npt2,hilf) int prec; numdata *npt1, *npt2; word2 *hilf; { int n, n1, n2; word2 *x, *y, *z; long exponent, diff; n1 = npt1->len; n2 = npt2->len; x = npt1->digits; y = npt2->digits; diff = n1 - prec; if(diff > 0) { x += diff; n1 -= diff; npt1->expo += diff << 4; } diff = n2 - prec; if(diff > 0) { y += diff; n2 -= diff; npt2->expo += diff << 4; } z = hilf + prec + 2; n = multbig(x,n1,y,n2,z,hilf); diff = (n > prec ? n - prec : 0); n -= diff; cpyarr(z+diff,n,npt1->digits); exponent = npt1->expo + npt2->expo + (diff << 4); if(exponent >= maxfltex) return(aERROR); else if(exponent <= -maxfltex) { exponent = MOSTNEGEX; n = 0; } npt1->len = n; npt1->expo = exponent; if(n == 0) npt1->sign = 0; else if((npt1->sign == npt2->sign) || (npt1->sign && npt2->sign)) npt1->sign = 0; else npt1->sign = MINUSBYTE; return(n); } /*-------------------------------------------------------------------*/ PUBLIC int divtrunc(prec,npt1,npt2,hilf) int prec; numdata *npt1, *npt2; word2 *hilf; { int n, n1, n2; int rlen; long exponent, diff; word2 *x, *y, *z; n1 = npt1->len; if(n1 == 0) return(0); n2 = npt2->len; if(n2 == 0) return(aERROR); /* Division durch 0 */ x = hilf + prec + 2; y = x + (prec << 1); z = y + prec; diff = n2 - prec; if(diff > 0) { y = npt2->digits + diff; npt2->expo += diff << 4; n2 -= diff; } else y = npt2->digits; diff = n2 + prec - n1; if(diff > 0) { setarr(x,(int)diff,0); cpyarr(npt1->digits,n1,x+diff); } else cpyarr(npt1->digits-diff,(int)(n1+diff),x); n1 += diff; npt1->expo -= diff << 4; n = divbig(x,n1,y,n2,z,&rlen,hilf); diff = n - prec; /* diff is 0 or 1 */ n -= diff; cpyarr(z+diff,n,npt1->digits); exponent = npt1->expo - npt2->expo + (diff << 4); if(exponent >= maxfltex) return(aERROR); else if(exponent <= -maxfltex) { exponent = MOSTNEGEX; n = 0; } npt1->expo = exponent; npt1->len = n; if(n == 0) npt1->sign = 0; else if(npt1->sign == npt2->sign || (npt1->sign && npt2->sign)) npt1->sign = 0; else npt1->sign = MINUSBYTE; return(n); } /*-------------------------------------------------------------------*/ /* ** die durch *nptr gegebene Zahl ist etwa 10**decdigs(nptr) */ PRIVATE long decdigs(nptr) numdata *nptr; { static unsigned a[3] = {3,31,22088}; /* log(2)/log(10) = 1/3 - 1/31 - 1/22088 */ word4 u; long b; int n, sign; b = n = nptr->len - 1; if(n < 0) return(MOSTNEGEX); b <<= 4; b += nptr->expo + bitlen(nptr->digits[n]); sign = (b < 0); u = (sign ? -b : b); b = (u/a[0] - u/a[1] - u/a[2]); b = (sign ? -b : b); return(b); } /*-------------------------------------------------------------------*/ /* ** berechnet base**a in *nptr mit prec 16-bit-Stellen */ PUBLIC int pwrtrunc(prec,base,a,nptr,hilf) int prec; unsigned base, a; numdata *nptr; word2 *hilf; { word2 *pow, *temp; long offs, offs1; unsigned bb; int len; temp = hilf + prec + 2; nptr->sign = 0; pow = nptr->digits; pow[0] = (a ? base : 1); len = 1; offs = 0; if(a <= 1) { bb = 0; } else if(a <= 0xFFFF) { bb = 1; bb <<= (bitlen(a)-2); } else { bb = 0x8000; bb <<= (bitlen(a>>16)-1); } while(bb) { len = multbig(pow,len,pow,len,temp,hilf); offs += offs; if((offs1 = len-prec) > 0) { offs += offs1; cpyarr(temp+offs1,prec,temp); len = prec; } if(a & bb) { len = multarr(temp,len,base,pow); if(len > prec) { /* dann len = prec+1 */ offs++; cpyarr(pow+1,prec,pow); len = prec; } } else cpyarr(temp,len,pow); bb >>= 1; } nptr->len = len; nptr->expo = (offs << 4); return(len); } /*-------------------------------------------------------------------*/ /* ** Verwandelt float-Zahl (gegeben in *p) in bcd-Zahl mit places Stellen ** Ist Rueckgabewert len != 0, so ist len = places und das ** Ergebnis gleich ** (arr,len) * 10**offs ** wobei arr = nptr->digits, offs = nptr->expo. ** Rueckgabewert 0 bedeutet die Zahl 0.0 ** arr muss mindestens die word2-Laenge (2 + places/4) haben ** Platz hilf muss word2-Laenge >= places + places/4 + 8 haben */ PUBLIC int float2bcd(places,p,nptr,hilf) int places; truc *p; numdata *nptr; word2 *hilf; { word2 *arr; long d, d1; int prec, prec1, n, sh; int flg = *FLAGPTR(p); prec = fltprec(flg); prec1 = places/4; if(prec > prec1) prec = prec1; prec +=1; if(getnumtrunc(prec,p,nptr) == 0) return(0); d = decdigs(nptr); d1 = places - d + 3; /* +3 wegen Rundungsfehlern */ n = malzehnhoch(prec,nptr,d1,hilf); arr = nptr->digits; cpyarr(arr,n,hilf); sh = nptr->expo; /* sh ist int! */ n = shiftarr(hilf,n,sh); nptr->len = big2bcd(hilf,n,arr); nptr->expo = -d1; return(roundbcd(places,nptr)); } /*--------------------------------------------------------------*/ /* ** Die in *nptr gegebene Float-Zahl wird auf prec signifikante ** Stellen gerundet */ PUBLIC int roundbcd(prec,nptr) int prec; numdata *nptr; { word2 *arr; int sh, len; int carry, dig; len = nptr->len; sh = len - prec; if(sh <= 0 || prec <= 0) return(len); arr = nptr->digits; dig = nibdigit(arr,sh-1); carry = (dig >= 5 ? 1 : 0); len = shiftbcd(arr,len,-sh); nptr->expo += sh; if(carry) len = incbcd(arr,len,carry); if(len > prec) { len = shiftbcd(arr,len,-1); nptr->expo++; } return(nptr->len = len); } /*------------------------------------------------------------------*/ /* ** Multipliziert die in *nptr gegebene Zahl mit 10**d ** auf prec 16-Bit-Stellen genau */ PRIVATE int malzehnhoch(prec,nptr,d,hilf) int prec; long d; numdata *nptr; word2 *hilf; { numdata p10; word2 *hilf1; unsigned int dd; int n; p10.digits = hilf; hilf1 = hilf + prec + 2; dd = (d >= 0 ? d : -d); pwrtrunc(prec,10,dd,&p10,hilf1); if(d >= 0) n = multtrunc(prec,nptr,&p10,hilf1); else n = divtrunc(prec,nptr,&p10,hilf1); return(n); } /*------------------------------------------------------------------*/ /* ** verwandelt die in *nptr gegebene Zahl, wobei sich nptr->expo ** auf die Basis 10 bezieht, in Zahl bezueglich Basis 2 */ PUBLIC int flodec2bin(prec,nptr,hilf) int prec; numdata *nptr; word2 *hilf; { long d; d = nptr->expo; nptr->expo = 0; return(malzehnhoch(prec,nptr,d,hilf)); } /*------------------------------------------------------------------*/ /* ** verwandelt integer x (darf nur 16 bit enthalten) in numdata */ PUBLIC void int2numdat(x,nptr) int x; numdata *nptr; { if(x < 0) { x = -x; nptr->sign = MINUSBYTE; } else nptr->sign = 0; *nptr->digits = x; nptr->len = (x ? 1 : 0); nptr->expo = (x ? 0 : MOSTNEGEX); } /*------------------------------------------------------------------*/ PUBLIC void cpynumdat(npt1,npt2) numdata *npt1, *npt2; { npt2->sign = npt1->sign; npt2->len = npt1->len; cpyarr(npt1->digits,npt1->len,npt2->digits); npt2->expo = npt1->expo; } /*-------------------------------------------------------------------*/ /* ** Ergibt +1, 0, -1, je nachdem Zahl in *ptr positiv, null oder ** negativ ist. */ PUBLIC int numposneg(ptr) truc *ptr; { int flg = *FLAGPTR(ptr); if(((flg == fFIXNUM) && *SIGNPTR(ptr)) || ((flg == fBIGNUM) && *SIGNUMPTR(ptr)) || ((flg >= fFLTOBJ) && (*SIGNUMPTR(ptr) & FSIGNBIT))) return(-1); else if((*ptr == zero) || ((flg >= fFLTOBJ) && (flg & FLTZEROBIT))) return(0); else return(1); } /*------------------------------------------------------------------*/ /* ** Loescht destruktiv das Vorzeichen der in *ptr gegebenen Zahl. */ PUBLIC truc wipesign(ptr) truc *ptr; { int flg = *FLAGPTR(ptr); if(flg == fFIXNUM) *SIGNPTR(ptr) = 0; else if(flg >= fFLTOBJ) { if((flg & FLTZEROBIT) == 0) *SIGNUMPTR(ptr) &= ~FSIGNBIT; } else /* bignums */ *SIGNUMPTR(ptr) = 0; return(*ptr); } /*------------------------------------------------------------------*/ /* ** Aendert destruktiv das Vorzeichen der in *ptr gegebenen Zahl. */ PUBLIC truc changesign(ptr) truc *ptr; { int sign, flg; sign = numposneg(ptr); if(sign == 0) return *ptr; else if(sign < 0) return wipesign(ptr); /* now *ptr is positive */ flg = *FLAGPTR(ptr); if(flg == fFIXNUM) *SIGNPTR(ptr) = MINUSBYTE; else if(flg >= fFLTOBJ) { *SIGNUMPTR(ptr) |= FSIGNBIT; } else /* bignums */ *SIGNUMPTR(ptr) = MINUSBYTE; return(*ptr); } /*------------------------------------------------------------------*/ /* ** holt long aus *ptr; ** falls abs(Zahl) >= 2 ** 31, Returnwert: LONGERROR */ PUBLIC long intretr(ptr) truc *ptr; { word2 *x; word4 u; long res; int n, sign; n = bigref(ptr,&x,&sign); if(n < 0 || n > 2 || (u = big2long(x,n)) >= 0x80000000) return(LONGERROR); res = u; return(sign ? -res : res); } /*------------------------------------------------------------------*/ /* ** Erzeugt Referenz auf Integer (bignum, fixnum oder gf2n_int) ohne Kopie ** Rueckgabe aERROR, falls *ptr kein fixnum, bignum oder gf2nint */ PUBLIC int bigref(ptr,xp,sp) truc *ptr; word2 **xp; int *sp; { struct bigcell *big; word2 *x; int flg = *FLAGPTR(ptr); if(flg == fFIXNUM) { *xp = x = WORD2PTR(ptr); *sp = *SIGNPTR(ptr); return(*x ? 1 : 0); } else if(flg == fBIGNUM || flg == fGF2NINT) { big = (struct bigcell *)TAddress(ptr); *sp = big->signum; *xp = &(big->digi0); return(big->len); } else return(aERROR); } /*------------------------------------------------------------------*/ /* ** holt Integer (fixnum oder bignum) aus *ptr nach x ** Vorzeichen in *sp ** Rueckgabe aERROR, falls *ptr kein fixnum oder bignum */ PUBLIC int bigretr(ptr,x,sp) truc *ptr; word2 *x; int *sp; { word2 *z; int n; n = bigref(ptr,&z,sp); if(n != aERROR) cpyarr(z,n,x); return(n); } /*-------------------------------------------------------------*/ /* ** holt Integer (fixnum oder bignum) aus *ptr nach x ** in Zweier-Komplement-Darstellung ** x[n] = 0, falls positiv; ** x[n] = 0xFFFF, falls negativ. */ PUBLIC int twocretr(ptr,x) truc *ptr; word2 *x; { int sign, n; n = bigretr(ptr,x,&sign); if(n < 0) return(n); if(sign) { n = decarr(x,n,1); notarr(x,n); x[n] = 0xFFFF; } else x[n] = 0; return(n); } /*-------------------------------------------------------------*/ PRIVATE int twocadjust(x,n) word2 *x; int n; { word2 u = x[n]; while((n > 0) && (x[n-1] == u)) n--; return(n); } /*-------------------------------------------------------------*/ /* ** Bitwise and of two bignums (x,n), (y,m) ** in two's complement representation ** Destructively replaces (x,n) by result */ PUBLIC int and2arr(x,n,y,m) word2 *x,*y; int n,m; { if(n < m && x[n]) { setarr(x+n+1,m-n,0xFFFF); n = m; } else if(m < n && !y[m]) { n = m; } andarr(x,m+1,y); n = twocadjust(x,n); return(n); } /*-------------------------------------------------------------*/ /* ** Bitwise or of two bignums (x,n), (y,m) ** in two's complement representation ** Destructively replaces (x,n) by result */ PUBLIC int or2arr(x,n,y,m) word2 *x,*y; int n,m; { if(n < m && !x[n]) { setarr(x+n+1,m-n,0); n = m; } else if(m < n && y[m]) { n = m; } orarr(x,m+1,y); n = twocadjust(x,n); return(n); } /*-------------------------------------------------------------*/ /* ** Bitwise xor of two bignums (x,n), (y,m) ** in two's complement representation ** Destructively replaces (x,n) by result */ PUBLIC int xor2arr(x,n,y,m) word2 *x,*y; int n,m; { if(n < m) { setarr(x+n+1,m-n,x[n]); n = m; } else if(m < n && y[m]) { setarr(y+m+1,n-m,0xFFFF); m = n; } xorarr(x,m+1,y); n = twocadjust(x,n); return(n); } /*-------------------------------------------------------------*/ /* ** Bitwise xor of two bitvectors (x,n), (y,m) ** Destructively replaces (x,n) by result */ PUBLIC int xorbitvec(x,n,y,m) word2 *x,*y; int n,m; { if(n < m) { setarr(x+n,m-n,0); n = m; } xorarr(x,m,y); while(n > 0 && x[n-1] == 0) n--; return(n); } /*-------------------------------------------------------------*/ PUBLIC long bit_length(x,n) word2 *x; int n; { long b; if(n > 0) { b = n - 1; b <<= 4; b += bitlen(x[n-1]); } else b = 0; return(b); } /*-------------------------------------------------------------*/ /* ** Prueft, ob die Elemente argptr[i], 0 <= i < n, Integers sind ** Rueckgabewert: fFIXNUM, fBIGNUM oder aERROR */ PUBLIC int chkints(sym,argptr,n) truc sym; truc *argptr; int n; { int flg, flg0 = fFIXNUM; while(--n >= 0) { flg = *FLAGPTR(argptr); if(flg < fFIXNUM || flg > fBIGNUM) return(error(sym,err_int,*argptr)); else if(flg > flg0) flg0 = flg; argptr++; } return(flg0); } /*------------------------------------------------------------------*/ /* ** checks whether element *ptr is an integer ** Return value: fFIXNUM, fBIGNUM or aERROR */ PUBLIC int chkint(sym,ptr) truc sym; truc *ptr; { int flg; flg = *FLAGPTR(ptr); if(flg < fFIXNUM || flg > fBIGNUM) return(error(sym,err_int,*ptr)); else return flg; } /*------------------------------------------------------------------*/ /* ** checks whether element *ptr is an integer or gf2nint ** Return value: fFIXNUM, fBIGNUM, fGF2NINT or aERROR */ PUBLIC int chkintt(sym,ptr) truc sym; truc *ptr; { int flg; flg = *FLAGPTR(ptr); if(flg < fINTTYPE0 || flg > fINTTYPE1) return(error(sym,err_intt,*ptr)); else return flg; } /*------------------------------------------------------------------*/ /* ** checks whether element *ptr is a nonzero integer ** Return value: fFIXNUM, fBIGNUM or aERROR */ PUBLIC int chkintnz(sym,ptr) truc sym; truc *ptr; { int flg; flg = *FLAGPTR(ptr); if(flg < fFIXNUM || flg > fBIGNUM) return(error(sym,err_int,*ptr)); else if(*ptr == zero) return(error(sym,err_div,voidsym)); else return flg; } /*-------------------------------------------------------------*/ /* ** Argument *vptr must be a vector. ** The function checks whether all components of this ** vector are integers. ** Return value: fFIXNUM, fBIGNUM or aERROR */ PUBLIC int chkintvec(sym,vptr) truc sym; truc *vptr; { struct vector *vec; truc *ptr; int len; int flg, flg0 = fFIXNUM; vec = VECSTRUCTPTR(vptr); len = vec->len; ptr = &(vec->ele0); while(--len >= 0) { flg = *FLAGPTR(ptr); if(flg < fFIXNUM || flg > fBIGNUM) return(error(sym,err_int,*ptr)); else if(flg > flg0) flg0 = flg; ptr++; } return(flg0); } /*-------------------------------------------------------------*/ /* ** Prueft, ob die Elemente argptr[i], 0 <= i < n, Integers oder ** Floats sind ** Rueckgabewert: fFIXNUM, fBIGNUM, Float-Flag oder aERROR */ PUBLIC int chknums(sym,argptr,n) truc sym; truc *argptr; int n; { int flg, flg0 = fFIXNUM; while(--n >= 0) { flg = *FLAGPTR(argptr); if(flg < fFIXNUM) return(error(sym,err_num,*argptr)); else if(flg > flg0) flg0 = flg; argptr++; } return(flg0); } /*-------------------------------------------------------------*/ PUBLIC int chknum(sym,ptr) truc sym; truc *ptr; { int flg = *FLAGPTR(ptr); if(flg < fFIXNUM) return(error(sym,err_num,*ptr)); return(flg); } /*-------------------------------------------------------------*/ /* ** Argument *vptr must be a vector. ** The function checks whether all components of this ** vector are integers. ** Return value: fFIXNUM, fBIGNUM, Float-flag or aERROR */ PUBLIC int chknumvec(sym,vptr) truc sym; truc *vptr; { struct vector *vec; truc *ptr; int len; int flg, flg0 = fFIXNUM; vec = VECSTRUCTPTR(vptr); len = vec->len; ptr = &(vec->ele0); while(--len >= 0) { flg = *FLAGPTR(ptr); if(flg < fFIXNUM) return(error(sym,err_num,*ptr)); else if(flg > flg0) flg0 = flg; ptr++; } return(flg0); } /***************************************************************/ aribas165b/src/arith.c0000644000076600000240000017724214660570651013657 0ustar ottostaff/****************************************************************/ /* file arith.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** arith.c ** arithmetic functions ** ** date of last change ** 1995-03-11: set_floatprec, get_floatprec ** 1997-02-20: fixed bug in Frandom() ** 1997-02-25: modified Fmod() ** 1997-03-31: error message in Gcompare ** 1997-04-13: reorg (newintsym) ** 2001-01-06: multiprec floats ** 2002-02-24: vector arithmetic, 1st step ** 2002-04-19: divide(x,y) ** 2003-02-11: addition of gf2n_int's ** 2003-02-15: Fdecode made safe wrt garbage collection ** 2003-11-21: removed bug in vecdiv ** 2007-02-23: changed negatevec to make it robust wrt gc ** 2007-11-15: function roundhalf: case of number exactly = 1/2 ** 2018-09-13 fixed minor errors and compiler warnings ** (thanks to D. Trebbien for testing) ** 2018-09-23 fixed bug in Fpower (case 0**-1) */ #include "common.h" PUBLIC void iniarith (void); PUBLIC truc addints (truc *ptr, int minflg); PUBLIC truc scalintvec (truc *ptr1, truc *ptr2); PUBLIC unsigned random2 (unsigned u); PUBLIC unsigned random4 (unsigned u); PUBLIC int cmpnums (truc *ptr1, truc *ptr2, int type); PUBLIC truc zero, constone; PUBLIC truc sfloatsym, dfloatsym, lfloatsym; PUBLIC truc realsym, integsym, int_sym; PUBLIC truc plussym, minussym, uminsym; PUBLIC truc timessym, divsym, modsym, divfsym, powersym; PUBLIC truc ariltsym, arigtsym, arilesym, arigesym; PUBLIC long maxfltex, maxdecex, exprange; /*-------------------------------------------------------------*/ PRIVATE truc Fplus (void); PRIVATE truc addfloats (truc *ptr, int minflg); PRIVATE truc Fminus (void); PRIVATE truc Fnegate (void); PRIVATE truc Sinc (void); PRIVATE truc Sdec (void); PRIVATE truc Sincaux (truc symb, int s); PRIVATE truc Fabsolute (void); PRIVATE truc Fmax (int argn); PRIVATE truc Fmin (int argn); PRIVATE truc Fmaxint (void); PRIVATE truc Gminmax (truc symb, int argn); PRIVATE truc Fodd (void); PRIVATE truc Feven (void); PRIVATE int odd (truc *ptr); PRIVATE truc Ftimes (void); PRIVATE truc multints (truc *ptr); PRIVATE truc multfloats (truc *ptr); PRIVATE truc Fsum (void); PRIVATE truc sumintvec (truc *argptr, int argn); PRIVATE truc sumfltvec (truc *argptr, int argn); PRIVATE truc Fprod (void); PRIVATE truc prodintvec (truc *argptr, int argn); PRIVATE truc prodfloatvec (truc *argptr, int argn); PRIVATE truc Fdivf (void); PRIVATE truc Fdiv (void); PRIVATE truc Fdivide (void); PRIVATE truc Fmod (void); PRIVATE truc Gvecmod (int flg); PRIVATE truc divide (truc *ptr, int tflag); PRIVATE truc modout (truc *ptr); PRIVATE truc divfloats (truc *ptr); PRIVATE truc Ftrunc (void); PRIVATE truc Fround (void); PRIVATE truc Ffloor (void); PRIVATE truc Ffrac (void); PRIVATE truc Gtruncaux (truc symb); PRIVATE void intfrac (numdata *npt1, numdata *np2); PRIVATE int roundhalf (numdata *nptr); PRIVATE void floshiftint (numdata *nptr); PRIVATE truc Fpower (void); PRIVATE truc exptints (truc *ptr, unsigned a); PRIVATE truc exptfloats (truc *ptr); PRIVATE int exptovfl (word2 *x, int n, unsigned a); PRIVATE truc Fisqrt (void); PRIVATE int cmpfloats (truc *ptr1, truc *ptr2, int prec); PRIVATE truc Farilt (void); PRIVATE truc Farigt (void); PRIVATE truc Farile (void); PRIVATE truc Farige (void); PRIVATE int Gcompare (truc symb); PRIVATE void inirandstate (word2 *rr); PRIVATE void nextrand (word2 *rr, int n); PRIVATE truc Frandom (void); PRIVATE truc Frandseed (int argn); PRIVATE int objfltprec (truc obj); PRIVATE truc Ffloat (int argn); PRIVATE truc Fsetfltprec (int argn); PRIVATE truc Fgetfltprec (int argn); PRIVATE truc Fmaxfltprec (void); PRIVATE truc Fsetprnprec (void); PRIVATE truc Fgetprnprec (void); PRIVATE int precdesc (truc obj); PRIVATE truc Fdecode (void); PRIVATE truc Fbitnot (void); PRIVATE truc Fbitset (void); PRIVATE truc Fbitclear (void); PRIVATE truc Gbitset (truc symb); PRIVATE truc Fbittest (void); PRIVATE truc Fbitshift (void); PRIVATE truc Fbitlength (void); PRIVATE truc Fbitcount (void); PRIVATE truc Fcardinal (void); PRIVATE truc Finteger (void); PRIVATE truc Gcardinal (truc symb); PRIVATE truc Fbitand (void); PRIVATE truc Fbitor (void); PRIVATE truc Fbitxor (void); PRIVATE truc Gboole (truc symb, ifunaa boolfun); PRIVATE truc negatevec (truc *ptr); PRIVATE truc addvecs (truc sym, truc *ptr); PRIVATE truc addintvecs (truc *ptr1, truc *ptr2); PRIVATE truc addfltvecs (truc *ptr1, truc *ptr2); PRIVATE truc scalvec (truc *ptr1, truc *ptr2); PRIVATE truc scalfltvec (truc *ptr1, truc *ptr2); PRIVATE truc vecdiv (truc *vptr, truc *zz); PRIVATE truc vecdivfloat (truc *vptr, truc *zz); PRIVATE int chkplusargs (truc sym, truc *argptr); PRIVATE int chktimesargs (truc *argptr); PRIVATE int chkmodargs (truc sym, truc *argptr); PRIVATE int chkdivfargs (truc sym, truc *argptr); PRIVATE truc floatsym; PRIVATE truc decodsym; PRIVATE truc sumsym, prodsym; PRIVATE truc bnotsym, bandsym, borsym, bxorsym, bshiftsym; PRIVATE truc btestsym, bsetsym, bclrsym, blensym, bcountsym; PRIVATE truc cardsym; PRIVATE truc maxsym, minsym; PRIVATE truc maxintsym; PRIVATE truc setfltsym, getfltsym, maxfltsym, setprnsym, getprnsym; PRIVATE truc incsym, decsym; PRIVATE truc abssym, oddsym, evensym; PRIVATE truc isqrtsym; PRIVATE truc dividesym, div_sym, mod_sym; PRIVATE truc truncsym, roundsym, fracsym, floorsym; PRIVATE truc randsym, rseedsym; PRIVATE word2 RandSeed[4]; PRIVATE word4 MaxBits; PRIVATE int curFltPrec; /*--------------------------------------------------------*/ PUBLIC void iniarith() { word4 u; zero = mkfixnum(0); constone = mkfixnum(1); integsym = newsym("integer", sTYPESPEC, zero); int_sym = new0symsig("integer", sFBINARY, (wtruc)Finteger, s_ii); realsym = newsym("real", sTYPESPEC, fltzero(deffltprec())); sfloatsym = newsym("single_float", sSYMBCONST, mkfixnum(FltPrec[0])); dfloatsym = newsym("double_float", sSYMBCONST, mkfixnum(FltPrec[1])); lfloatsym = newsym("long_float", sSYMBCONST, mkfixnum(FltPrec[2])); floatsym = newsymsig("float", sFBINARY, (wtruc)Ffloat, s_12rn); setfltsym = newsymsig("set_floatprec", sFBINARY, (wtruc)Fsetfltprec, s_12); getfltsym = newsymsig("get_floatprec", sFBINARY, (wtruc)Fgetfltprec, s_01); maxfltsym = newsymsig("max_floatprec", sFBINARY, (wtruc)Fmaxfltprec,s_0); setprnsym = newsymsig("set_printprec", sFBINARY, (wtruc)Fsetprnprec,s_1); getprnsym = newsymsig("get_printprec", sFBINARY, (wtruc)Fgetprnprec,s_0); decodsym = newsymsig("decode_float",sFBINARY,(wtruc)Fdecode, s_vr); plussym = newintsym("+", sFBINARY, (wtruc)Fplus); minussym = newintsym("-", sFBINARY, (wtruc)Fminus); uminsym = newintsym("-", sFBINARY, (wtruc)Fnegate); timessym = newintsym("*", sFBINARY, (wtruc)Ftimes); divfsym = newintsym("/", sFBINARY, (wtruc)Fdivf); powersym = newintsym("**", sFBINARY, (wtruc)Fpower); sumsym = newsymsig("sum", sFBINARY, (wtruc)Fsum, s_nv); prodsym = newsymsig("product",sFBINARY, (wtruc)Fprod, s_nv); divsym = newintsym("div",sFBINARY, (wtruc)Fdiv); div_sym = newsym("div", sINFIX, divsym); SYMcc1(div_sym) = DIVTOK; dividesym = newsymsig("divide",sFBINARY, (wtruc)Fdivide, s_2); modsym = newintsym("mod",sFBINARY, (wtruc)Fmod); mod_sym = newsym("mod", sINFIX, modsym); SYMcc1(mod_sym) = MODTOK; abssym = newsymsig("abs", sFBINARY, (wtruc)Fabsolute,s_rr); maxsym = newsymsig("max", sFBINARY, (wtruc)Fmax,s_1u); minsym = newsymsig("min", sFBINARY, (wtruc)Fmin,s_1u); maxintsym = newsymsig("max_intsize", sFBINARY, (wtruc)Fmaxint,s_0); oddsym = newsymsig("odd", sFBINARY, (wtruc)Fodd,s_ii); evensym = newsymsig("even", sFBINARY, (wtruc)Feven,s_ii); incsym = newsymsig("inc", sSBINARY, (wtruc)Sinc,s_12ii); decsym = newsymsig("dec", sSBINARY, (wtruc)Sdec,s_12ii); isqrtsym = newsymsig("isqrt", sFBINARY, (wtruc)Fisqrt,s_ii); truncsym = newsymsig("trunc", sFBINARY, (wtruc)Ftrunc, s_rr); roundsym = newsymsig("round", sFBINARY, (wtruc)Fround, s_rr); floorsym = newsymsig("floor", sFBINARY, (wtruc)Ffloor, s_rr); fracsym = newsymsig("frac", sFBINARY, (wtruc)Ffrac, s_rr); randsym = newsymsig("random", sFBINARY, (wtruc)Frandom, s_rr); rseedsym = newsymsig("random_seed",sFBINARY,(wtruc)Frandseed, s_01); ariltsym = newintsym("<", sFBINARY, (wtruc)Farilt); arigtsym = newintsym(">", sFBINARY, (wtruc)Farigt); arilesym = newintsym("<=", sFBINARY, (wtruc)Farile); arigesym = newintsym(">=", sFBINARY, (wtruc)Farige); bnotsym = newsymsig("bit_not", sFBINARY, (wtruc)Fbitnot, s_ii); bandsym = newsymsig("bit_and", sFBINARY, (wtruc)Fbitand, s_iii); borsym = newsymsig("bit_or", sFBINARY, (wtruc)Fbitor, s_iii); bxorsym = newsymsig("bit_xor", sFBINARY, (wtruc)Fbitxor, s_iii); btestsym = newsymsig("bit_test", sFBINARY, (wtruc)Fbittest,s_iii); bsetsym = newsymsig("bit_set", sFBINARY, (wtruc)Fbitset, s_iii); bclrsym = newsymsig("bit_clear",sFBINARY, (wtruc)Fbitclear, s_iii); bshiftsym = newsymsig("bit_shift",sFBINARY, (wtruc)Fbitshift, s_iii); blensym = newsymsig("bit_length",sFBINARY,(wtruc)Fbitlength,s_ii); bcountsym = newsymsig("bit_count",sFBINARY, (wtruc)Fbitcount,s_ii); cardsym = newsymsig("cardinal", sFBINARY, (wtruc)Fcardinal,s_ii); u = aribufSize; u <<= 4; MaxBits = u; u -= 256; if(u > MAXFLTLIM) u = MAXFLTLIM; maxfltex = u; maxdecex = (u/10) * 3; exprange = u - u/3 + u/38; /* log(2) = 1 - 1/3 + 1/38 */ inirandstate(RandSeed); iniaritx(); iniarity(); iniaritz(); } /*--------------------------------------------------------*/ #define DIVFLAG 1 #define MODFLAG 2 #define DDIVFLAG (DIVFLAG | MODFLAG) /*--------------------------------------------------------*/ PRIVATE truc Fplus() { truc res; int type; type = chkplusargs(plussym,argStkPtr-1); if(type > fBIGNUM) { curFltPrec = deffltprec(); res = addfloats(argStkPtr-1,0); } else switch(type) { case fFIXNUM: case fBIGNUM: res = addints(argStkPtr-1,0); break; case fVECTOR: res = addvecs(plussym,argStkPtr-1); break; case fGF2NINT: res = addgf2ns(argStkPtr-1); break; case aERROR: default: res = brkerr(); break; } return(res); } /*--------------------------------------------------------*/ PUBLIC truc addints(ptr,minflag) truc *ptr; int minflag; /* if minflag != 0, subtract */ { word2 *y; int n1, n2, n; int sign1, sign2, sign, cmp; n1 = bigretr(ptr,AriBuf,&sign1); n2 = bigref(ptr+1,&y,&sign2); if(minflag) { sign2 = (sign2 ? 0 : MINUSBYTE); } if(sign1 == sign2) { sign = sign1; n = addarr(AriBuf,n1,y,n2); } else { cmp = cmparr(AriBuf,n1,y,n2); if(cmp > 0) { sign = sign1; n = subarr(AriBuf,n1,y,n2); } else if(cmp < 0) { sign = sign2; n = sub1arr(AriBuf,n1,y,n2); } else return(zero); } return(mkint(sign,AriBuf,n)); } /*-------------------------------------------------------------*/ PRIVATE truc addfloats(ptr,minflag) truc *ptr; int minflag; { numdata accum, temp; int prec, cmp; prec = curFltPrec + 1; if(prec < 3) prec++; accum.digits = AriBuf; temp.digits = AriScratch; getnumalign(prec,ptr,&accum); getnumalign(prec,ptr+1,&temp); if(minflag) temp.sign = (temp.sign ? 0 : MINUSBYTE); adjustoffs(&accum,&temp); if(accum.sign == temp.sign) { accum.len = addarr(accum.digits,accum.len,temp.digits,temp.len); } else { cmp = cmparr(accum.digits,accum.len,temp.digits,temp.len); if(cmp > 0) { accum.len = subarr(accum.digits,accum.len,temp.digits,temp.len); } else if(cmp < 0) { accum.sign = temp.sign; accum.len = sub1arr(accum.digits,accum.len,temp.digits,temp.len); } else { accum.len = 0; } } return(mkfloat(curFltPrec,&accum)); } /*--------------------------------------------------------*/ PRIVATE truc Fminus() { truc res; int type; type = chkplusargs(minussym,argStkPtr-1); if(type > fBIGNUM) { curFltPrec = deffltprec(); res = addfloats(argStkPtr-1,-1); } else switch(type) { case fFIXNUM: case fBIGNUM: res = addints(argStkPtr-1,-1); break; case fVECTOR: res = addvecs(minussym,argStkPtr-1); break; case fGF2NINT: res = addgf2ns(argStkPtr-1); break; case aERROR: default: res = brkerr(); break; } return(res); } /*--------------------------------------------------------*/ PRIVATE truc Fnegate() { int flg; truc res[1]; flg = *FLAGPTR(argStkPtr); if(flg >= fFIXNUM) { res[0] = mkcopy(argStkPtr); changesign(res); return res[0]; } else if(flg == fVECTOR) { flg = chknumvec(uminsym,argStkPtr); if(flg == aERROR) return brkerr(); else return negatevec(argStkPtr); } else if(flg == fGF2NINT) { return *argStkPtr; } else { /* flg == aERROR */ error(uminsym,err_num,*argStkPtr); return brkerr(); } } /*--------------------------------------------------------*/ PRIVATE truc Sinc() { return(Sincaux(incsym,1)); } /*--------------------------------------------------------*/ PRIVATE truc Sdec() { return(Sincaux(decsym,-1)); } /*--------------------------------------------------------*/ PRIVATE truc Sincaux(symb,s) truc symb; int s; { truc res; long number; int argn; int flg; argn = *ARGCOUNTPTR(evalStkPtr); res = eval(ARG1PTR(evalStkPtr)); ARGpush(res); if(argn == 2) { res = eval(ARGNPTR(evalStkPtr,2)); ARGpush(res); } flg = chkints(symb,argStkPtr-argn+1,argn); if(flg == aERROR) { ARGnpop(argn); return(brkerr()); } else if(argn == 1 && flg == fFIXNUM) { number = *WORD2PTR(argStkPtr); if(*SIGNPTR(argStkPtr)) number = -number; res = mkinum(number + s); ARGpop(); } else { if(argn == 1) ARGpush(constone); s = (s > 0 ? 0 : -1); res = addints(argStkPtr-1,s); ARGnpop(2); } return(Lvalassign(ARG1PTR(evalStkPtr),res)); } /*--------------------------------------------------------*/ PRIVATE truc Ftimes() { truc res; int type; type = chktimesargs(argStkPtr-1); if(type <= fBIGNUM) { switch(type) { case fFIXNUM: case fBIGNUM: res = multints(argStkPtr-1); break; case fGF2NINT: res = multgf2ns(argStkPtr-1); break; default: /* type == aERROR */ res = brkerr(); } } else if((type & 0xFF00) == 0) { /* float obj */ curFltPrec = deffltprec(); res = multfloats(argStkPtr-1); } else if((type >> 8) == fVECTOR) { type |= 0xFF; if(type >= fFIXNUM) { res = scalvec(argStkPtr-1,argStkPtr); } else if(type == fGF2NINT) { error(timessym,err_imp,voidsym); res = brkerr(); } else res = brkerr(); } else { error(timessym,err_case,mksfixnum(type)); res = brkerr(); } return(res); } /*----------------------------------------------------------*/ /* ** multiply integers in ptr[0] and ptr[1] */ PRIVATE truc multints(ptr) truc *ptr; { word2 *x, *y; int n1, n2, n, sign, sign2; n1 = bigref(ptr,&x,&sign); n2 = bigref(ptr+1,&y,&sign2); if(n1 + n2 >= aribufSize) goto errexit; else if(!n1 || !n2) return(zero); n = multbig(x,n1,y,n2,AriBuf,AriScratch); sign = (sign == sign2 ? 0 : MINUSBYTE); return(mkint(sign,AriBuf,n)); errexit: error(timessym,err_ovfl,voidsym); return(brkerr()); } /*---------------------------------------------------------*/ PRIVATE truc multfloats(ptr) truc *ptr; { numdata prod, temp; int prec; int n; prec = curFltPrec + 1; prod.digits = AriBuf; n = getnumtrunc(prec,ptr,&prod); refnumtrunc(prec,ptr+1,&temp); n = multtrunc(prec,&prod,&temp,AriScratch); if(n < 0) { error(timessym,err_ovfl,voidsym); return(brkerr()); } return(mkfloat(curFltPrec,&prod)); } /*--------------------------------------------------------*/ PRIVATE truc negatevec(ptr) truc *ptr; { truc res; truc tmp[1]; int len,k; WORKpush(zero); WORKpush(mkcopy(ptr)); len = *VECLENPTR(workStkPtr); for(k=0; k flg) flg = flg0; if(flg <= fBIGNUM) { return scalintvec(ptr1,ptr2); } else { curFltPrec = deffltprec(); return scalfltvec(ptr1,ptr2); } } /*---------------------------------------------------------*/ /* ** Multiplies int vector given in *ptr2 by scalar in *ptr1 ** uses AriBuf and AriScratch */ PUBLIC truc scalintvec(ptr1,ptr2) truc *ptr1, *ptr2; { truc obj; int len, k; WORKpush(*ptr1); WORKpush(constone); obj = mkcopy(ptr2); WORKpush(obj); len = *VECLENPTR(ptr2); for(k=0; klen; if(argn == 0) { error(symb,err_args,*argStkPtr); goto errexit; } argptr = &(vptr->ele0); } else argptr = argStkPtr - argn + 1; if((type = chknums(symb,argptr,argn)) == aERROR) goto errexit; ptr = argptr++; while(--argn > 0) { cmp = cmpnums(ptr,argptr,type); if(symb == minsym) cmp = -cmp; if(cmp < 0) ptr = argptr; argptr++; } return(*ptr); errexit: return brkerr(); } /*--------------------------------------------------------*/ PRIVATE truc Fodd() { int ret = odd(argStkPtr); if(ret == aERROR) return(brkerr()); return(ret ? true : false); } /*--------------------------------------------------------*/ PRIVATE truc Feven() { int ret = odd(argStkPtr); if(ret == aERROR) return(brkerr()); return(ret ? false : true); } /*--------------------------------------------------------*/ PRIVATE int odd(ptr) truc *ptr; { word2 *x; int sign; if(bigref(ptr,&x,&sign) == aERROR) return(aERROR); else return(x[0] & 1); } /*---------------------------------------------------------*/ PRIVATE truc Fsum() { struct vector *vec; truc *ptr; long res; int flg; int len; if(*FLAGPTR(argStkPtr) != fVECTOR) { error(sumsym,err_vect,*argStkPtr); return(brkerr()); } vec = VECSTRUCTPTR(argStkPtr); len = vec->len; ptr = &(vec->ele0); flg = chknums(sumsym,ptr,len); if(flg == fFIXNUM) { res = 0; while(--len >= 0) { if(*SIGNPTR(ptr)) res -= *WORD2PTR(ptr); else res += *WORD2PTR(ptr); ptr++; } return(mkinum(res)); } else if(flg == fBIGNUM) { return(sumintvec(ptr,len)); } else if(flg >= fFLTOBJ) { curFltPrec = deffltprec(); return(sumfltvec(ptr,len)); } else /* vector elements are not numbers */ return(brkerr()); } /*-------------------------------------------------------------*/ /* ** sum up all elements of integer vector *argptr of length len */ PRIVATE truc sumintvec(argptr,len) truc *argptr; int len; { word2 *y; int sign, cmp, n0, n1, m; n0 = n1 = 0; while(--len >= 0) { m = bigref(argptr,&y,&sign); if(sign) n1 = addarr(AriScratch,n1,y,m); else n0 = addarr(AriBuf,n0,y,m); argptr++; } cmp = cmparr(AriBuf,n0,AriScratch,n1); if(cmp < 0) { sign = MINUSBYTE; m = sub1arr(AriBuf,n0,AriScratch,n1); } else { sign = 0; m = subarr(AriBuf,n0,AriScratch,n1); } return(mkint(sign,AriBuf,m)); } /*-------------------------------------------------------------*/ /* ** sum up all elements of float vector *argptr of length len */ PRIVATE truc sumfltvec(argptr,len) truc *argptr; int len; { numdata accum, negsum, temp; numdata *nptr; int prec; int cmp, sign; prec = curFltPrec + 1; accum.digits = AriBuf; negsum.digits = AriScratch; temp.digits = AriScratch + aribufSize; accum.len = 0; accum.expo = MOSTNEGEX; negsum.len = 0; negsum.expo = MOSTNEGEX; while(--len >= 0) { if(!getnumalign(prec,argptr++,&temp)) continue; sign = temp.sign; nptr = (sign ? &negsum : &accum); adjustoffs(nptr,&temp); nptr->len = addarr(nptr->digits,nptr->len,temp.digits,temp.len); } adjustoffs(&accum,&negsum); cmp = cmparr(accum.digits,accum.len,negsum.digits,negsum.len); if(cmp < 0) { accum.sign = MINUSBYTE; accum.len = sub1arr(accum.digits,accum.len,negsum.digits,negsum.len); } else { accum.sign = 0; accum.len = subarr(accum.digits,accum.len,negsum.digits,negsum.len); } return(mkfloat(curFltPrec,&accum)); } /*---------------------------------------------------------*/ PRIVATE truc Fprod() { struct vector *vec; truc *ptr; int flg; int len; if(*FLAGPTR(argStkPtr) != fVECTOR) { error(prodsym,err_vect,*argStkPtr); return(brkerr()); } vec = VECSTRUCTPTR(argStkPtr); len = vec->len; if(!len) return(constone); ptr = &(vec->ele0); flg = chknums(prodsym,ptr,len); if(flg == aERROR) return(brkerr()); if(flg <= fBIGNUM) return(prodintvec(ptr,len)); else { /* flg >= fFLTOBJ */ curFltPrec = deffltprec(); return(prodfloatvec(ptr,len)); } } /*----------------------------------------------------------*/ /* ** multiplies all elements of integer vector *argptr of length len */ PRIVATE truc prodintvec(argptr,len) truc *argptr; int len; { word2 *y, *hilf; int n1, n, sign, sign1; unsigned a; if(len == 0) return(constone); n = bigref(argptr++,&y,&sign); cpyarr(y,n,AriBuf); hilf = AriScratch + aribufSize; while(--len > 0) { if(*FLAGPTR(argptr) == fFIXNUM) { a = *WORD2PTR(argptr); n = multarr(AriBuf,n,a,AriBuf); if(n >= aribufSize) goto errexit; sign1 = *SIGNPTR(argptr); } else { n1 = bigref(argptr,&y,&sign1); if(n + n1 >= aribufSize) goto errexit; cpyarr(AriBuf,n,AriScratch); n = multbig(AriScratch,n,y,n1,AriBuf,hilf); } if(n == 0) { sign = 0; break; } if(sign1) sign = (sign ? 0 : MINUSBYTE); argptr++; } return(mkint(sign,AriBuf,n)); errexit: error(prodsym,err_ovfl,voidsym); return(brkerr()); } /*---------------------------------------------------------*/ /* ** multiplies all elements of float vector *argptr of length len */ PRIVATE truc prodfloatvec(argptr,len) truc *argptr; int len; /* len >= 1 */ { numdata prod, temp; int prec; int n; prec = curFltPrec + 1; prod.digits = AriBuf; n = getnumtrunc(prec,argptr++,&prod); while(--len > 0 && n > 0) { refnumtrunc(prec,argptr++,&temp); n = multtrunc(prec,&prod,&temp,AriScratch); } if(n < 0) { error(prodsym,err_ovfl,voidsym); return(brkerr()); } return(mkfloat(curFltPrec,&prod)); } /*---------------------------------------------------------*/ PRIVATE truc Fdivf() { int type, flg; type = chkdivfargs(divfsym,argStkPtr-1); if(type == aERROR) { return brkerr(); } else if(type == fGF2NINT) { return divgf2ns(argStkPtr-1); } if((*argStkPtr == zero) || ((flg = *FLAGPTR(argStkPtr)) >= fFLTOBJ && (flg & FLTZEROBIT))) { error(divfsym,err_div,voidsym); return brkerr(); } curFltPrec = deffltprec(); if((type & 0xFF00) == 0) { return(divfloats(argStkPtr-1)); } /* else first argument is vector */ flg = chknumvec(divfsym,argStkPtr-1); if(flg == aERROR) { return brkerr(); } else { return(vecdivfloat(argStkPtr-1,argStkPtr)); } } /*----------------------------------------------------------*/ PRIVATE truc Fdiv() { int type, flg; type = chkmodargs(divsym,argStkPtr-1); if(type == aERROR) { return(brkerr()); } if(*argStkPtr == zero) { error(divsym,err_div,voidsym); return(brkerr()); } if((type & 0xFF00) == 0) return(divide(argStkPtr-1,DIVFLAG)); /* else first argument is vector */ flg = chkintvec(divsym,argStkPtr-1); if(flg == aERROR) { return(brkerr()); } else { return(vecdiv(argStkPtr-1,argStkPtr)); } } /*----------------------------------------------------------*/ /* ** Divide integer vector given in *vptr by integer *zz */ PRIVATE truc vecdiv(vptr,zz) truc *vptr; truc *zz; { truc *ptr; truc obj; word2 *z, *hilf; int k, len, len1, len2, rlen, sign1, sign2; hilf = AriScratch + aribufSize; len = *VECLENPTR(vptr); WORKpush(mkcopy(vptr)); for(k=0; klen; if(n == 0 || npt1->expo >= 0) { int2numdat(0,npt2); return; } n = alignfloat(n+1,npt1); expo = npt1->expo; k = (-expo) >> 4; /* div 16, geht auf */ if(k >= n) { cpynumdat(npt1,npt2); int2numdat(0,npt1); } else { x = npt1->digits; while(k > 0 && x[k-1] == 0) k--; cpyarr(x,k,npt2->digits); setarr(x,k,0); npt2->len = k; npt2->expo = expo; npt2->sign = npt1->sign; } } /*------------------------------------------------------------------*/ /* ** Ergibt 1 oder 0, je nachdem die in *nptr gegebene Zahl absolut ** groesser oder kleiner 1/2 ist. ** If the number equals exactly 1/2, the return value is 2 */ PRIVATE int roundhalf(nptr) numdata *nptr; { long nn; word2 *xx; int i, bb, len; len = nptr->len; if (len == 0) return 0; xx = nptr->digits; nn = bit_length(xx,len); if (nn < -nptr->expo) return 0; if (nn == -nptr->expo) { for (i=0; i < len-1; i++) { if (xx[i]) return 1; } bb = (nn - 1) % 16; if (xx[len-1] != (1 << bb)) return 1; else return 2; } else return 1; } /*------------------------------------------------------------------*/ PRIVATE void floshiftint(nptr) numdata *nptr; { nptr->len = lshiftarr(nptr->digits,nptr->len,nptr->expo); nptr->expo = 0; } /*------------------------------------------------------------------*/ PRIVATE truc Fpower() { int flg, flg2, sign, m; unsigned int a; word2 *aa; flg = *FLAGPTR(argStkPtr-1); flg2 = *FLAGPTR(argStkPtr); if(flg >= fFIXNUM) { if(flg2 >= fFIXNUM) flg = (flg2 >= flg ? flg2 : flg); else { error(powersym,err_num,*argStkPtr); return brkerr(); } } else if(flg == fGF2NINT) { if(flg2 == fFIXNUM || flg2 == fBIGNUM) { return exptgf2n(argStkPtr-1); } else { error(powersym,err_int,*argStkPtr); return brkerr(); } } else { error(powersym,err_intt,argStkPtr[-1]); return brkerr(); } if(flg == aERROR) return brkerr(); else if(flg <= fBIGNUM) { if(argStkPtr[-1] == zero) { if (argStkPtr[0] == zero) return constone; else { sign = numposneg(argStkPtr); if(sign >= 0) { return zero; } else { error(powersym,err_p0num,*argStkPtr); return brkerr(); } } } else if(argStkPtr[-1] == constone) return constone; else { m = bigref(argStkPtr,&aa,&sign); if(sign) { flg = fFLTOBJ; /* vorlaeufig */ } else if(m <= 2) { a = big2long(aa,m); return exptints(argStkPtr-1,a); } else { error(powersym,err_ovfl,voidsym); return brkerr(); } } } if(flg >= fFLTOBJ) { curFltPrec = deffltprec(); return exptfloats(argStkPtr-1); } else { error(powersym,err_case,voidsym); return brkerr(); } } /*----------------------------------------------------------------*/ PRIVATE truc exptints(ptr,a) truc *ptr; unsigned a; { word2 *x, *temp, *hilf; int sign, n; n = bigref(ptr,&x,&sign); if(exptovfl(x,n,a)) { error(powersym,err_ovfl,voidsym); return(brkerr()); } temp = AriScratch; hilf = temp + aribufSize; n = power(x,n,a,AriBuf,temp,hilf); sign = (a & 1 ? sign : 0); return(mkint(sign,AriBuf,n)); } /*----------------------------------------------------------------*/ PRIVATE truc exptfloats(ptr) truc *ptr; { numdata acc, acc2; word2 *hilf; int prec, flg, len; int odd, sign = 0; acc.digits = AriBuf; acc2.digits = AriScratch; hilf = AriScratch + aribufSize; prec = curFltPrec + 1; len = getnumtrunc(prec,ptr,&acc); if(!len) { sign = numposneg(ptr+1); if(sign < 0) { goto errexit; } else { int2numdat((sign > 0 ? 0 : 1),&acc); goto ausgang; } } if(acc.sign) { flg = *FLAGPTR(ptr+1); if(flg > fBIGNUM) { goto errexit; } else { odd = (flg == fFIXNUM ? *WORD2PTR(ptr+1) & 1 : *BIGNUMPTR(ptr+1) & 1); sign = (odd ? MINUSBYTE : 0); } acc.sign = 0; } len = lognum(prec,&acc,hilf); if(len >= 0) { getnumtrunc(prec,ptr+1,&acc2); len = multtrunc(prec,&acc,&acc2,hilf); } if(len >= 0) len = expnum(prec,&acc,hilf); if(len == aERROR) { error(powersym,err_ovfl,voidsym); return(brkerr()); } acc.sign = sign; ausgang: return(mkfloat(curFltPrec,&acc)); errexit: error(powersym,err_pnum,*ptr); return(brkerr()); } /*----------------------------------------------------------------*/ /* ** Stellt fest, ob (x,n)**a zu overflow fuehrt. ** Rueckgabe aERROR bei overflow, oder 0 sonst */ PRIVATE int exptovfl(x,n,a) word2 *x; int n; unsigned a; { numdata pow; word4 bitbound, b; if(n == 0 || a <= 1) return(0); bitbound = MaxBits/a; b = n - 1; b <<= 4; b += bitlen(x[n-1]); if(b <= bitbound) return(0); else if(n > 1 || b > bitbound+1) return(aERROR); else if(n == 1 && x[0] == 2 && a < MaxBits) return(0); pow.digits = AriBuf; pwrtrunc(2,x[0],256,&pow,AriScratch); /******* oder mit log1_16() ****************/ b = pow.expo; b += ((pow.len-1)<<4) + bitlen(pow.digits[pow.len-1]); bitbound = (MaxBits << 8)/a; return(b > bitbound ? aERROR : 0); } /*------------------------------------------------------------------*/ PRIVATE truc Fisqrt() { word2 *x, *z, *hilf; int sign, n, rlen; z = AriBuf; x = AriScratch; hilf = x + aribufSize; n = bigretr(argStkPtr,x,&sign); if(n == aERROR) { error(isqrtsym,err_int,*argStkPtr); return(brkerr()); } if(sign) { error(isqrtsym,err_p0num,*argStkPtr); return(brkerr()); } n = bigsqrt(x,n,z,&rlen,hilf); return(mkint(0,z,n)); } /*------------------------------------------------------------------*/ /* ** returns 1 (resp. 0, -1) if number in *ptr1 is ** bigger than (resp. equal, smaller than) number in *ptr2 */ PUBLIC int cmpnums(ptr1,ptr2,type) truc *ptr1, *ptr2; int type; /* must be an integer or float type */ { word2 *x, *y; int n1, n2, sign1, sign2, cmp; if(*ptr1 == *ptr2) return(0); if(type == fFIXNUM) { sign1 = *SIGNPTR(ptr1); sign2 = *SIGNPTR(ptr2); if(sign1 != sign2) return(sign1 ? -1 : 1); cmp = (*WORD2PTR(ptr1) > *WORD2PTR(ptr2) ? 1 : -1); return(sign1 ? -cmp : cmp); } else if(type == fBIGNUM) { n1 = bigref(ptr1,&x,&sign1); n2 = bigref(ptr2,&y,&sign2); if(sign1 != sign2) return(sign1 ? -1 : 1); cmp = cmparr(x,n1,y,n2); return(sign1 ? -cmp : cmp); } else if(type == fGF2NINT) { n1 = bigref(ptr1,&x,&sign1); n2 = bigref(ptr2,&y,&sign2); return cmparr(x,n1,y,n2); } else if(type >= fFLTOBJ) { return(cmpfloats(ptr1,ptr2,fltprec(type)+1)); } else return(aERROR); } /*-------------------------------------------------------------------*/ PRIVATE int cmpfloats(ptr1,ptr2,prec) truc *ptr1, *ptr2; int prec; { numdata npt1, npt2; long expo1, expo2; int cmp, sign1, n1, n2; npt1.digits = AriBuf; npt2.digits = AriScratch; getnumtrunc(prec,ptr1,&npt1); getnumtrunc(prec,ptr2,&npt2); sign1 = npt1.sign; if(sign1 != npt2.sign) return(sign1 ? -1 : 1); n1 = normfloat(prec,&npt1); n2 = normfloat(prec,&npt2); expo1 = npt1.expo; expo2 = npt2.expo; if(expo1 > expo2) { return(sign1 ? -1 : 1); } else if(expo1 < expo2) { return(sign1 ? 1 : -1); } else { cmp = cmparr(npt1.digits,n1,npt2.digits,n2); return(sign1 ? -cmp : cmp); } } /*-----------------------------------------------------------*/ /* ** Num1 < Num2 */ PRIVATE truc Farilt() { int cmp = Gcompare(ariltsym); if(cmp == aERROR) return(brkerr()); else return(cmp < 0 ? true : false); } /*-------------------------------------------------------------*/ /* ** Num1 > Num2 */ PRIVATE truc Farigt() { int cmp = Gcompare(arigtsym); if(cmp == aERROR) return(brkerr()); else return(cmp > 0 ? true : false); } /*-----------------------------------------------------------*/ /* ** Num1 <= Num2 */ PRIVATE truc Farile() { int cmp = Gcompare(arilesym); if(cmp == aERROR) return(brkerr()); else return(cmp <= 0 ? true : false); } /*---------------------------------------------------------------*/ /* ** Num1 >= Num2 */ PRIVATE truc Farige() { int cmp = Gcompare(arigesym); if(cmp == aERROR) return(brkerr()); else return(cmp >= 0 ? true : false); } /*---------------------------------------------------------------*/ PRIVATE int Gcompare(symb) truc symb; { truc obj; char *errmsg; char *str1, *str2; int type, type1; type = *FLAGPTR(argStkPtr); if(type >= fFIXNUM) { if((type1 = *FLAGPTR(argStkPtr-1)) >= fFIXNUM) { type = (type >= type1 ? type : type1); return(cmpnums(argStkPtr-1,argStkPtr,type)); } else { errmsg = err_mism; obj = argStkPtr[-1]; } } else if(type == fSTRING) { if(*FLAGPTR(argStkPtr-1) == fSTRING) { str1 = STRINGPTR(argStkPtr-1); str2 = STRINGPTR(argStkPtr); return(strcmp(str1,str2)); } else { errmsg = err_mism; obj = argStkPtr[-1]; } } else if(type == fCHARACTER) { if(*FLAGPTR(argStkPtr-1) == fCHARACTER) { return(*WORD2PTR(argStkPtr-1) - *WORD2PTR(argStkPtr)); } else { errmsg = err_mism; obj = argStkPtr[-1]; } } else { errmsg = err_type; obj = argStkPtr[0]; } return(error(symb,errmsg,obj)); } /*--------------------------------------------------------*/ PRIVATE void inirandstate(rr) word2 *rr; { rr[1] = sysrand(); nextrand(rr,3); rr[0] = sysrand(); nextrand(rr,3); rr[3] = 1; } /*--------------------------------------------------------*/ PRIVATE void nextrand(rr,n) word2 *rr; int n; { /* for compilers which don't understand 57777U */ static unsigned inc = 57777, scal = 56857; /* 57777 = 1 mod 4, 56857 prime */ incarr(rr,n,inc); multarr(rr,n,scal,rr); rr[3] = 1; } /*------------------------------------------------------------------*/ /* ** 2-byte random integer */ PUBLIC unsigned random2(u) unsigned u; { nextrand(RandSeed,2); return(RandSeed[1] % u); } /*------------------------------------------------------------------*/ /* ** 4-byte random integer */ PUBLIC unsigned random4(u) unsigned u; { word4 v; nextrand(RandSeed,3); v = big2long(RandSeed+1,2); return(v % u); } /*------------------------------------------------------------------*/ /* ** random(bound) */ PRIVATE truc Frandom() { numdata acc, acc2; word2 *x; unsigned a, b; int i, n, m, prec, type; type = chknum(randsym,argStkPtr); if(type == aERROR) return(brkerr()); if(type == fFIXNUM) { nextrand(RandSeed,2); a = *WORD2PTR(argStkPtr); if(!a) return(zero); b = RandSeed[1] % a; return(mkfixnum(b)); } else if(type >= fFLTOBJ) { curFltPrec = deffltprec(); prec = curFltPrec + 1; for(x=AriBuf, i=0; i 0 && AriBuf[m-1] == 0) m--; x = BIGNUMPTR(argStkPtr); m = modbig(AriBuf,m,x,n,AriScratch); return(mkint(0,AriBuf,m)); } } /*------------------------------------------------------------------*/ PRIVATE truc Frandseed(argn) int argn; { word2 *x; int sign, n, m; if(argn == 1) { n = bigref(argStkPtr,&x,&sign); if(n != aERROR) { m = (n > 3 ? 3 : n); cpyarr(x,m,RandSeed); setarr(RandSeed+m,3-m,0); } } return(mkint(0,RandSeed,4)); } /*------------------------------------------------------------------*/ PRIVATE int objfltprec(obj) truc obj; { variant v; int flg, prec; if(obj == sfloatsym || obj == dfloatsym || obj == lfloatsym) { v.xx = SYMbind(obj); prec = v.pp.ww; } else { v.xx = obj; flg = v.pp.b0; if(flg >= fFLTOBJ) prec = fltprec(flg); else prec = deffltprec(); } return(prec); } /*------------------------------------------------------------------*/ PRIVATE truc Ffloat(argn) int argn; /* argn = 1 or 2 */ { truc *argptr; numdata xx; int prec; if(argn == 1) prec = deffltprec(); else prec = precdesc(*argStkPtr); argptr = argStkPtr - argn + 1; if(chknum(floatsym,argptr) == aERROR) return(*argptr); xx.digits = AriBuf; getnumtrunc(prec+1,argptr,&xx); return(mkfloat(prec,&xx)); } /*------------------------------------------------------------------*/ PRIVATE int precdesc(obj) truc obj; { variant v; int flg, prec, bits; if(obj == sfloatsym || obj == dfloatsym || obj == lfloatsym) { v.xx = SYMbind(obj); prec = v.pp.ww; } else { v.xx = obj; flg = v.pp.b0; if(flg == fFIXNUM) { bits = v.pp.ww; prec = (bits + 15)/16; } else prec = deffltprec(); } return(prec); } /*------------------------------------------------------------------*/ PRIVATE truc Fsetfltprec(argn) int argn; { int prec; truc obj; int prnflg = 1; if(argn == 2) { obj = argStkPtr[-1]; if(*argStkPtr == zero) prnflg = 0; } else obj = *argStkPtr; prec = precdesc(obj); prec = setfltprec(prec); if(prnflg) setprnprec(prec); return(mkfixnum(16*prec)); } /*------------------------------------------------------------------*/ PRIVATE truc Fsetprnprec() { int prec; prec = precdesc(*argStkPtr); prec = setprnprec(prec); return(mkfixnum(16*prec)); } /*------------------------------------------------------------------*/ PRIVATE truc Fgetprnprec() { int prec; prec = setprnprec(-1); return(mkfixnum(16*prec)); } /*------------------------------------------------------------------*/ PRIVATE truc Fgetfltprec(argn) int argn; { int prec; if(argn == 0) prec = deffltprec(); else prec = objfltprec(*argStkPtr); return(mkfixnum(16*prec)); } /*-------------------------------------------------------------*/ PRIVATE truc Fmaxfltprec() { int prec; prec = maxfltprec(); return(mkfixnum(16*prec)); } /*-------------------------------------------------------------*/ PRIVATE truc Fdecode() { truc *ptr; truc vec, obj; numdata acc; long expo; int flg, len; flg = *FLAGPTR(argStkPtr); if(flg < fFLTOBJ) { if(flg >= fFIXNUM) { *argStkPtr = Ffloat(1); flg = *FLAGPTR(argStkPtr); } else { error(decodsym,err_float,*argStkPtr); return(brkerr()); } } len = fltprec(flg); acc.digits = AriBuf; len = getnumtrunc(len,argStkPtr,&acc); expo = (len ? acc.expo : 0); obj = mkint(acc.sign,AriBuf,len); WORKpush(obj); obj = mkinum(expo); WORKpush(obj); vec = mkvect0(2); ptr = VECTOR(vec); ptr[1] = WORKretr(); ptr[0] = WORKretr(); return(vec); } /*-------------------------------------------------------------*/ PRIVATE truc Fbitnot() { int n, sign; if(chkints(bnotsym,argStkPtr,1) == aERROR) return(brkerr()); n = bigretr(argStkPtr,AriBuf,&sign); if(sign) { n = decarr(AriBuf,n,1); sign = 0; } else { n = incarr(AriBuf,n,1); sign = 1; } return(mkint(sign,AriBuf,n)); } /*-------------------------------------------------------------*/ PRIVATE truc Fbitset() { return(Gbitset(bsetsym)); } /*-------------------------------------------------------------*/ PRIVATE truc Fbitclear() { return(Gbitset(bclrsym)); } /*-------------------------------------------------------------*/ PRIVATE truc Gbitset(symb) truc symb; { word2 *x, *y; word4 index; int b, n, n1, m, sign, sign1; word2 u, mask = 1; if(chkints(symb,argStkPtr-1,2) == aERROR) return(brkerr()); x = AriBuf; n = twocretr(argStkPtr-1,x); u = x[n]; sign = (u == 0xFFFF ? MINUSBYTE : 0); n1 = bigref(argStkPtr,&y,&sign1); if(sign1) { error(symb,err_p0num,*argStkPtr); return(brkerr()); } if(n1 > 2) index = 0xFFFF0; else index = big2long(y,n1); b = index & 0xF; index >>= 4; m = index; if(index >= n) { if((sign && symb == bsetsym) || (!sign && symb == bclrsym)) { return(argStkPtr[-1]); /* no action taken */ } else if(index >= aribufSize) { error(symb,err_ovfl,voidsym); return(argStkPtr[-1]); } else { setarr(x+n+1,m-n,u); n = m + 1; } } mask <<= b; if(symb == bsetsym) x[m] |= mask; else x[m] &= ~mask; while((n > 0) && (x[n-1] == u)) n--; if(sign) { notarr(x,n); n = incarr(x,n,1); } return(mkint(sign,x,n)); } /*-------------------------------------------------------------*/ PRIVATE truc Fbittest() { word2 *x; long index; int k, b, n, sign; word2 mask = 1; if(chkintt(btestsym,argStkPtr-1) == aERROR || chkint(btestsym,argStkPtr) == aERROR) return(brkerr()); n = bigref(argStkPtr-1,&x,&sign); if(sign) { x = AriBuf; n = twocretr(argStkPtr-1,x); } index = intretr(argStkPtr); if(index == LONGERROR) return(sign ? constone : zero); else if(index < 0) { error(btestsym,err_p0num,*argStkPtr); return(brkerr()); } k = index >> 4; if(index > 0x7FFF0 || k >= n) return(sign ? constone : zero); b = index & 0xF; mask <<= b; return(x[k] & mask ? constone : zero); } /*-------------------------------------------------------------*/ PRIVATE truc Fbitshift() { long sh, nn; int n, sign; if(chkints(bshiftsym,argStkPtr-1,2) == aERROR) return(brkerr()); nn = n = bigretr(argStkPtr-1,AriBuf,&sign); sh = intretr(argStkPtr); if(sh == LONGERROR || sh >= maxfltex - (nn<<4)) { error(bshiftsym,err_ovfl,voidsym); return(brkerr()); } if(sign && sh < 0) { n = decarr(AriBuf,n,1); n = lshiftarr(AriBuf,n,sh); n = incarr(AriBuf,n,1); } else n = lshiftarr(AriBuf,n,sh); return(mkint(sign,AriBuf,n)); } /*-------------------------------------------------------------*/ PRIVATE truc Fbitlength() { word2 *x; long len; int n, sign; if(chkintt(blensym,argStkPtr) == aERROR) return(brkerr()); n = bigref(argStkPtr,&x,&sign); len = bit_length(x,n); return(mkinum(len)); } /*-------------------------------------------------------------*/ PRIVATE truc Fbitcount() { word2 *x; long count; int k, n, sign; if(chkintt(blensym,argStkPtr) == aERROR) return(brkerr()); n = bigref(argStkPtr,&x,&sign); count = 0; for(k=0; k= aribufSize*2 - 2) { error(symb,err_2long,mkfixnum(len)); return(brkerr()); } bpt = (byte *)STRINGPTR(argStkPtr); if(symb == int_sym && (bpt[len-1] & 0x80)) sign = MINUSBYTE; n = len / 2; x = AriBuf; for(i=0; i 0 && AriBuf[n-1] == 0) n--; return(mkint(sign,AriBuf,n)); } /*-------------------------------------------------------------*/ PRIVATE truc Fbitand() { return(Gboole(bandsym,and2arr)); } /*-------------------------------------------------------------*/ PRIVATE truc Fbitor() { return(Gboole(borsym,or2arr)); } /*-------------------------------------------------------------*/ PRIVATE truc Fbitxor() { return(Gboole(bxorsym,xor2arr)); } /*------------------------------------------------------------------*/ PRIVATE truc Gboole(symb,boolfun) truc symb; ifunaa boolfun; { int sign; int n, m; if(chkints(symb,argStkPtr-1,2) == aERROR) return(brkerr()); n = twocretr(argStkPtr-1,AriBuf); m = twocretr(argStkPtr,AriScratch); n = boolfun(AriBuf,n,AriScratch,m); sign = (AriBuf[n] == 0xFFFF ? MINUSBYTE : 0); if(sign) { notarr(AriBuf,n); n = incarr(AriBuf,n,1); } return(mkint(sign,AriBuf,n)); } /*--------------------------------------------------------*/ PRIVATE int chkplusargs(sym,argptr) truc sym; truc *argptr; { int flg, flg1; flg = *FLAGPTR(argptr); flg1 = *FLAGPTR(argptr+1); if(flg >= fFIXNUM) { if(flg1 >= fFIXNUM) return (flg1 >= flg ? flg1 : flg); else return error(sym,err_num,argptr[1]); } else if((flg == flg1) && (flg == fVECTOR || flg == fGF2NINT)) return flg; else return error(sym,err_num,*argptr); } /*--------------------------------------------------------*/ PRIVATE int chktimesargs(argptr) truc *argptr; { int flg, flg1; truc ele; flg = *FLAGPTR(argptr); flg1 = *FLAGPTR(argptr+1); if(flg < fFIXNUM) { if(flg == fVECTOR) { /* then second argument must be a scalar */ if(flg1 >= fFIXNUM || flg1 == fGF2NINT) { /* swap args */ ele = *argptr; *argptr = argptr[1]; *(argptr+1) = ele; return (flg1 | (flg << 8)); } else return error(timessym,err_num,argptr[1]); } else if(flg == fGF2NINT) { if(flg1 == flg) return flg; else if(flg1 == fVECTOR) return (flg | (flg1 << 8)); } return error(timessym,err_num,*argptr); } /* here flg >= fFIXNUM */ if(flg1 >= fFIXNUM) { return (flg1 >= flg ? flg1 : flg); } else if(flg1 == fVECTOR) return (flg | (flg1 << 8)); else return error(timessym,err_num,argptr[1]); } /*--------------------------------------------------------*/ PRIVATE int chkmodargs(sym,argptr) truc sym; truc *argptr; { int flg, flg0; flg0 = *FLAGPTR(argptr+1); if(flg0 < fFIXNUM || flg0 > fBIGNUM) return error(sym,err_num,argptr[1]); flg = *FLAGPTR(argptr); if((flg < fFIXNUM && flg != fVECTOR) || (flg > fBIGNUM)) return error(sym,err_num,argptr[0]); if(flg == fVECTOR) return((fVECTOR<<8) | flg0); else return(flg0); } /*--------------------------------------------------------*/ PRIVATE int chkdivfargs(sym,argptr) truc sym; truc *argptr; { int flg, flg0; flg0 = *FLAGPTR(argptr+1); /* denominator flag */ flg = *FLAGPTR(argptr); /* numerator flag */ if(flg0 < fFIXNUM) { if(flg0 == fGF2NINT && flg == flg0) return flg; else return error(sym,err_num,argptr[1]); } if(flg < fFIXNUM && flg != fVECTOR) return error(sym,err_num,argptr[0]); if(flg == fVECTOR) return((fVECTOR<<8) | flg0); else return(flg0); } /*********************************************************************/ aribas165b/src/aritool0.c0000644000076600000240000003001414660570650014261 0ustar ottostaff/****************************************************************/ /* file aritool0.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** aritool0.c ** Hilfsprozeduren fuer Integer-Arithmetik (bignums) ** koennen zur Beschleunigung in Assembler geschrieben werden */ /* ** date of last change ** 95-02-01 ** 97-02-24: pointer arithmetic in sumarr, diffarr, diff1arr */ #include "common.h" int sumarr (word2 *x, int n, word2 *y); int diffarr (word2 *x, int n, word2 *y); int diff1arr (word2 *x, int n, word2 *y); int incarr (word2 *x, int n, unsigned a); int decarr (word2 *x, int n, unsigned a); void cpyarr (word2 *x, int n, word2 *y); void cpyarr1 (word2 *x, int n, word2 *y); int cmparr (word2 *x, int n, word2 *y, int m); int shrarr (word2 *x, int n, int k); int shlarr (word2 *x, int n, int k); void setarr (word2 *x, int n, unsigned a); void notarr (word2 *x, int n); void andarr (word2 *x, int n, word2 *y); void orarr (word2 *x, int n, word2 *y); void xorarr (word2 *x, int n, word2 *y); unsigned int2bcd (unsigned x); unsigned bcd2int (unsigned x); int big2bcd (word2 *x, int n, word2 *y); int long2big (word4 u, word2 *x); word4 big2long (word2 *x, int n); word4 intsqrt (word4 u); int bitlen (unsigned x); int niblen (unsigned x); int bitcount (unsigned u); #ifndef ASSEMB86 /* ** falls ASSEMB86 definiert ist, werden die folgenden Funktionen ** durch Assembler-Code ersetzt */ int multarr (word2 *x, int n, unsigned a, word2 *y); int divarr (word2 *x, int n, unsigned a, word2 *restptr); unsigned modarr (word2 *x, int n, unsigned a); /*-------------------------------------------------------------------*/ /* ** y = (x,n) * a ** funktioniert auch, wenn Platz y gleich oder <= Platz x */ int multarr(x,n,a,y) word2 *x, *y; unsigned a; int n; { register word4 u, carry = 0; int nn; if(a <= 1) { if(!a) return(0); else { cpyarr(x,n,y); return(n); } } nn = n; while(--n >= 0) { u = *x++; u *= a; u += carry; *y++ = u & 0xFFFF; carry = (u >> 16); } if(carry) { *y = carry; nn++; } return(nn); } /*-------------------------------------------------------------------*/ /* ** dividiert Array (x,n) destruktiv durch 16-bit-Zahl a ** und speichert Rest in *restptr */ int divarr(x,n,a,restptr) word2 *x, *restptr; unsigned a; int n; { register word4 u; word2 *xx; int nn; if(n == 0) { *restptr = 0; return(0); } xx = x += n; u = 0; nn = n; while(--n >= 0) { u <<= 16; u += *--x; *x = u/a; u %= a; } *restptr = u; return(*--xx ? nn : nn-1); } /*-------------------------------------------------------------------*/ /* ** Berechnet den Rest der Division von (x,n) durch 16-bit-Zahl a ** Das Array (x,n) bleibt erhalten */ unsigned modarr(x,n,a) word2 *x; int n; unsigned a; { register word4 u; if(n == 0 || a <= 1) return(0); x += n; u = 0; while(--n >= 0) { u <<= 16; u += *--x; u %= a; } return(u); } /*-------------------------------------------------------------------*/ #else #undef ASSEMB86 #endif /*-------------------------------------------------------------------*/ /* ** (x,n) := (x,n) + (y,n) ** returns 1, if carry is generated, else returns 0 */ int sumarr(x,n,y) word2 *x, *y; int n; { register word4 u; unsigned carry = 0; while(--n >= 0) { u = *x; u += *y++; u += carry; *x++ = u & 0xFFFF; carry = (u >= 0x10000 ? 1 : 0); } return(carry); } /*-------------------------------------------------------------------*/ /* ** (x,n) := (x,n) - (y,n) ** returns 1, if borrow is generated, else returns 0 */ int diffarr(x,n,y) word2 *x, *y; int n; { register word4 u; unsigned borrow = 0; while(--n >= 0) { u = *x; u -= *y++; u -= borrow; *x++ = u & 0xFFFF; borrow = (u & 0xFFFF0000 ? 1 : 0); } return(borrow); } /*-------------------------------------------------------------------*/ /* ** (x,n) := (y,n) - (x,n) ** returns 1, if borrow is generated, else returns 0 */ int diff1arr(x,n,y) word2 *x, *y; int n; { register word4 u; unsigned borrow = 0; while(--n >= 0) { u = *y++; u -= *x; u -= borrow; *x++ = u & 0xFFFF; borrow = (u & 0xFFFF0000 ? 1 : 0); } return(borrow); } /*-------------------------------------------------------------------*/ /* ** addiert zu Array (x,n) die 16-bit-Zahl a ** arbeitet destruktiv auf x */ int incarr(x,n,a) word2 *x; int n; unsigned a; { word4 u; int nn = n; while(a && --n >= 0) { u = *x; u += a; *x++ = u & 0xFFFF; a = (u >= 0x10000 ? 1 : 0); } if(a) { *x = a; nn++; } return(nn); } /*-------------------------------------------------------------------*/ /* ** subtrahiert von Array x die 16-bit-Zahl a ** arbeitet destruktiv auf x ** setzt voraus x >= a */ int decarr(x,n,a) word2 *x; int n; unsigned a; { register word4 u; word2 *xx; int nn; if(n == 0) return(0); xx = x + n - 1; nn = n; while(a && --n >= 0) { u = *x; u -= a; *x++ = u & 0xFFFF; a = (u & 0xFFFF0000 ? 1 : 0); } if(*xx == 0) nn--; return(nn); } /*-------------------------------------------------------------------*/ /* ** kopiert (x,n) nach y beginnend von unten */ void cpyarr(x,n,y) word2 *x, *y; int n; { while(--n >= 0) *y++ = *x++; } /*-------------------------------------------------------------------*/ /* ** kopiert (x,n) nach y beginnend von oben */ void cpyarr1(x,n,y) word2 *x, *y; int n; { x += n; y += n; while(--n >= 0) *--y = *--x; } /*-------------------------------------------------------------------*/ /* ** liefert +1, falls (x,n) > (y,m); ** -1, falls (x,n) < (y,m); ** 0, falls (x,n) = (y,m); */ int cmparr(x,n,y,m) word2 *x, *y; int n, m; { if(n != m) return(n > m ? 1 : -1); if(!n) return(0); x += n; y += n; while(--n >= 0) if(*--x != *--y) break; if(*x > *y) return(1); else if(*x < *y) return(-1); else return(0); } /*-------------------------------------------------------------------*/ /* ** Rechtsshift von (x,n) um k Bits; 0 <= k <= 15 ** arbeitet destruktiv auf x */ int shrarr(x,n,k) word2 *x; int n, k; { int i, k1 = 16 - k; word2 temp; if(!k || !n) return(n); for(i=1; i>= k; temp = *(x+1) << k1; *x++ |= temp; } *x >>= k; return(*x ? n : n-1); } /*-------------------------------------------------------------------*/ /* ** Linksshift von (x,n) um k Bits; 0 <= k <= 15 ** arbeitet destruktiv auf x */ int shlarr(x,n,k) word2 *x; int n, k; { int i, k1 = 16 - k; word2 u = 0, temp; if(!k || !n) return(n); for(i=0; i> k1); } if(u) { *x = u; n++; } return(n); } /*-------------------------------------------------------------------*/ void setarr(x,n,a) word2 *x; int n; unsigned a; { while(--n >= 0) *x++ = a; } /*-------------------------------------------------------------------*/ void notarr(x,n) word2 *x; int n; { while(--n >= 0) { *x = ~*x; x++; } } /*-------------------------------------------------------------------*/ void andarr(x,n,y) word2 *x, *y; int n; { while(--n >= 0) { *x++ &= *y++; } } /*-------------------------------------------------------------------*/ void orarr(x,n,y) word2 *x, *y; int n; { while(--n >= 0) { *x++ |= *y++; } } /*-------------------------------------------------------------------*/ void xorarr(x,n,y) word2 *x, *y; int n; { while(--n >= 0) { *x++ ^= *y++; } } /*-------------------------------------------------------------------*/ unsigned int2bcd(x) unsigned x; { int i; word2 a[3]; unsigned y; for(i=0; i<3; i++) { a[i] = x % 10; x /= 10; } y = x; /* a[3] */ for(i=2; i>=0; i--) y = (y<<4) + a[i]; return(y); } /*-------------------------------------------------------------------*/ unsigned bcd2int(x) unsigned x; { int i; word2 a[3]; unsigned y; for(i=0; i<3; i++) { a[i] = (0x000F & x); x >>= 4; } y = x; for(i=2; i>=0; i--) y = y*10 + a[i]; return(y); } /*-------------------------------------------------------------------*/ /* ** verwandelt big-Array (x,n) in bcd-Array y ** !!! arbeitet destruktiv auf x !!! ** Rueckgabewert Anzahl der Dezimalstellen von x */ int big2bcd(x,n,y) word2 *x, *y; int n; { int k = -1; if(!n) return(0); while(n) { n = divarr(x,n,10000,y); *y = int2bcd(*y); y++; k++; } return(k*4 + niblen(*--y)); } /*-------------------------------------------------------------------*/ int long2big(u,x) word4 u; word2 *x; { if(u == 0) return(0); x[0] = u; if(u < 0x10000) return(1); else { x[1] = (u >> 16); return(2); } } /*-------------------------------------------------------------------*/ word4 big2long(x,n) word2 *x; int n; { word4 u = 0; if(n >= 2) { u = x[1]; u <<= 16; } if(n >= 1) u += x[0]; return(u); } /*-------------------------------------------------------------------*/ /* ** berechnet die groesste ganze Zahl x mit x*x <= u */ word4 intsqrt(u) word4 u; { word4 v, x, x1, b; int n; if(!u) return(0); v = 0x40000000; x = 0x8000; n = 15; while(v > u) { v >>= 2; x >>= 1; n--; } b = x; u -= v; while(--n >= 0) { b >>= 1; x1 = x + b; v = (x + x1) << n; if(u >= v) { x = x1; u -= v; } } return(x); } /*------------------------------------------------------------------*/ /* ** bestimmt Laenge in Bits einer 16-Bit-Zahl x ** 0 <= bitlen <= 16; bitlen = 0 <==> x == 0; */ int bitlen(x) unsigned x; { int len; unsigned mask; if(x & 0xFF00) { len = 16; mask = 0x8000; } else if(x) { len = 8; mask = 0x0080; } else return(0); while(!(x & mask)) { mask >>= 1; len--; } return(len); } /*-------------------------------------------------------------------*/ int niblen(x) unsigned x; { int len = 4; unsigned mask = 0xF000; if(!x) return(0); while(!(x & mask)) { mask >>= 4; len--; } return(len); } /*-------------------------------------------------------------------*/ /* ** returns number of set bits in 16-bit number u */ PUBLIC int bitcount(u) unsigned u; { unsigned mask = 1; int count = 0; int k; for(k=0; k<16; k++) { if(u & mask) count++; else if(mask > u) break; mask <<= 1; } return count; } /*********************************************************************/ aribas165b/src/aritools.c0000644000076600000240000007014014660570651014371 0ustar ottostaff/****************************************************************/ /* file aritools.c ARIBAS interpreter for Arithmetic Copyright (C) 1999-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** aritools.c ** tools fuer bignum-Arithmetik ** ** vorzeichenlose bignums werden als Paare (x,n) dargestellt, ** wobei n eine ganze Zahl >= 0 und x ein Array (x[0],...,x[n-1]) ** von unsigned 16-bit-Zahlen ist; fuer die Zahl 0 ist n = 0, ** sonst ist stets n > 0 und x[n-1] != 0 ** ** Rueckgabewert der Funktionen meist Laenge des Resultat-Arrays ** ** Typen: word2 ist unsigned 16-bit-Zahl, word4 unsigned 32-bit-Zahl */ /*-------------------------------------------------------------------*/ /* ** date of last change ** 1995-10-29: modification of function biggcd ** 1997-02-25: more M_3264 support in multbig, divbig and modbig ** 1999-06-03: power for exponents a >= 2**16; return to old version of modbig ** 2002-04-20: modmultbig, addsarr ** 2003-06-16: modnegbig ** 2003-11-09: bugfix in function divbig ** 2024-08-19: minor change in function addsarr */ #include "common.h" PUBLIC int shiftarr (word2 *x, int n, int sh); PUBLIC int lshiftarr (word2 *x, int n, long sh); PUBLIC int addarr (word2 *x, int n, word2 *y, int m); PUBLIC int subarr (word2 *x, int n, word2 *y, int m); PUBLIC int sub1arr (word2 *x, int n, word2 *y, int m); PUBLIC int addsarr (word2 *x, int n, int sign1, word2 *y, int m, int sign2, int *psign); PUBLIC int multbig (word2 *x, int n, word2 *y, int m, word2 *z, word2 *hilf); PUBLIC int divbig (word2 *x, int n, word2 *y, int m, word2 *quot, int *rlenptr, word2 *hilf); PUBLIC int modbig (word2 *x, int n, word2 *y, int m, word2 *hilf); PUBLIC int modnegbig (word2 *x, int n, word2 *y, int m, word2 *hilf); PUBLIC int modmultbig (word2 *xx, int xlen, word2 *yy, int ylen, word2 *mm, int mlen, word2 *zz, word2 *hilf); PUBLIC int multfix (int prec, word2 *x, int n, word2 *y, int m, word2 *z, word2 *hilf); PUBLIC int divfix (int prec, word2 *x, int n, word2 *y, int m, word2 *z, word2 *hilf); PUBLIC unsigned shortgcd (unsigned x, unsigned y); PUBLIC int biggcd (word2 *x, int n, word2 *y, int m, word2 *hilf); PUBLIC int power (word2 *x, int n, unsigned a, word2 *p, word2 *temp, word2 *hilf); PUBLIC int bigsqrt (word2 *x, int n, word2 *z, int *rlenptr, word2 *temp); PUBLIC int lbitlen (word4 x); PUBLIC int bcd2big (word2 *x, int n, word2 *y); PUBLIC int str2int (char *str, int *panz); PUBLIC int str2big (char *str, word2 *arr, word2 *hilf); PUBLIC int bcd2str (word2 *arr, int n, char *str); PUBLIC int big2xstr (word2 *arr, int n, char *str); PUBLIC int digval (int ch); PUBLIC int xstr2big (char *str, word2 *arr); PUBLIC int ostr2big (char *str, word2 *arr); PUBLIC int bstr2big (char *str, word2 *arr); PUBLIC int nibdigit (word2 *arr, int k); PUBLIC int nibndigit (int n, word2 *arr, long k); PUBLIC int nibascii (word2 *arr, int k); PUBLIC int hexascii (int n); PUBLIC int shiftbcd (word2 *arr, int n, int k); PUBLIC int incbcd (word2 *x, int n, unsigned a); /*-------------------------------------------------------------*/ PRIVATE int shlaux (word2 *x, int n, int k, int b); PRIVATE int shraux (word2 *x, int n, int k, int b); PRIVATE unsigned nibble (unsigned x, int k); PRIVATE int str2barr (char *str, int b, word2 *arr); PRIVATE int nthbit (word2 *arr, long n); #define DECBASE 10000 /*-------------------------------------------------------------------*/ /* ** Shift von (x,n) um sh bit-Stellen ** sh > 0: Links-Shift; sh < 0: Rechts-Shift ** arbeitet destruktiv auf x ** x muss genuegend lang sein */ PUBLIC int shiftarr(x,n,sh) word2 *x; int n, sh; { int k, b; if(!n || !sh) return(n); k = (sh > 0 ? sh : -sh); b = k & 0x000F; k >>= 4; if(sh > 0) return(shlaux(x,n,k,b)); else return(shraux(x,n,k,b)); } /*-------------------------------------------------------------------*/ PRIVATE int shlaux(x,n,k,b) word2 *x; int n,k,b; { cpyarr1(x,n,x+k); n = k + shlarr(x+k,n,b); setarr(x,k,0); return(n); } /*-------------------------------------------------------------------*/ PRIVATE int shraux(x,n,k,b) word2 *x; int n,k,b; { if(k >= n) return(0); n -= k; cpyarr(x+k,n,x); return(shrarr(x,n,b)); } /*-------------------------------------------------------------------*/ /* ** Shift von (x,n) um sh bit-Stellen ** sh ist long, aber abs(sh) >> 4 muss integer sein ** sh > 0: Links-Shift; sh < 0: Rechts-Shift ** arbeitet destruktiv auf x ** x muss genuegend lang sein */ PUBLIC int lshiftarr(x,n,sh) word2 *x; int n; long sh; { int k, b; word4 a; if(!n || !sh) return(n); a = (sh > 0 ? sh : -sh); k = a >> 4; b = a & 0x0000000F; if(sh > 0) return(shlaux(x,n,k,b)); else return(shraux(x,n,k,b)); } /*-------------------------------------------------------------------*/ /* ** x := (x,n) + (y,m) */ PUBLIC int addarr(x,n,y,m) word2 *x, *y; int n, m; { int k; if(n < m) { cpyarr(y+n,m-n,x+n); k = m; /* swap m, n */ m = n; n = k; } if(sumarr(x,m,y)) n = m + incarr(x+m,n-m,1); return(n); } /*-------------------------------------------------------------------*/ /* ** x := (x,n) - (y,m) ** setzt voraus, dass (x,n) >= (y,m) */ PUBLIC int subarr(x,n,y,m) word2 *x, *y; int n, m; { if(diffarr(x,m,y)) n = m + decarr(x+m,n-m,1); while(n > 0 && x[n-1] == 0) n--; return(n); } /*-------------------------------------------------------------------*/ /* ** x := -(x,n) + (y,m) ** setzt voraus, dass (y,m) >= (x,n) */ PUBLIC int sub1arr(x,n,y,m) word2 *x, *y; int n, m; { if(n < m) cpyarr(y+n,m-n,x+n); if(diff1arr(x,n,y)) m = n + decarr(x+n,m-n,1); while(m > 0 && x[m-1] == 0) m--; return(m); } /*-------------------------------------------------------------------*/ /* ** Addition of signed bigintegers ** non-negative numbers: sign = 0; ** negative numbers: sign = MINUSBYTE; ** ** array x is overwritten with the result; must be long enough ** sign of result in *psign */ PUBLIC int addsarr(x,n,sign1,y,m,sign2,psign) word2 *x, *y; int n,m; int sign1, sign2; int *psign; { int k; int cmp; if(sign1 == sign2) { *psign = sign1; if(n < m) { cpyarr(y+n,m-n,x+n); k = m; /* swap m, n */ m = n; n = k; } if(sumarr(x,m,y)) n = m + incarr(x+m,n-m,1); return(n); } /* else */ cmp = cmparr(x,n,y,m); if(cmp > 0) { *psign = sign1; if(diffarr(x,m,y)) n = m + decarr(x+m,n-m,1); while(n > 0 && x[n-1] == 0) n--; return(n); } else if(cmp < 0) { *psign = sign2; if(n < m) cpyarr(y+n,m-n,x+n); if(diff1arr(x,n,y)) m = n + decarr(x+n,m-n,1); while(m > 0 && x[m-1] == 0) m--; return(m); } else { *psign = 0; return 0; } } /*-------------------------------------------------------------------*/ /* ** z := (x,n) * (y,m) ** Rueckgabewert Laenge von z ** hilf ist Platz fuer Hilfsvariable; ** muss mindestens max(n,m) + 2 lang sein */ PUBLIC int multbig(x,n,y,m,z,hilf) word2 *x, *y, *z, *hilf; int n, m; { int hilflen, zlen; #ifdef M_3264 word4 u; #endif if(!n || !m) return(0); if(m == 1) return(multarr(x,n,(unsigned)*y,z)); else if(n == 1) return(multarr(y,m,(unsigned)*x,z)); #ifdef M_3264 else if(m == 2) { u = big2long(y,2); return(mult4arr(x,n,u,z)); } else if(n == 2) { u = big2long(x,2); return(mult4arr(y,m,u,z)); } setarr(z,m-1,0); if(m & 1) { y += m-1; z += m-1; zlen = multarr(x,n,(unsigned)*y,z); } else { y += m; z += m; zlen = -2; } while(m >= 2) { m -= 2; z -= 2; zlen += 2; u = *--y; u <<= 16; u += *--y; hilflen = mult4arr(x,n,u,hilf); zlen = addarr(z,zlen,hilf,hilflen); } return(zlen); #else setarr(z,m-1,0); y += m; z += m; zlen = -1; while(--m >= 0) { hilflen = multarr(x,n,(unsigned)*--y,hilf); zlen = addarr(--z,++zlen,hilf,hilflen); } return(zlen); #endif } /*-------------------------------------------------------------------*/ /* ** Ersetzt (x,n) destruktiv durch (x,n) mod (y,m) */ PUBLIC int modbig(x,n,y,m,hilf) word2 *x, *y, *hilf; int n, m; { word4 u, v; unsigned a; int cmp, b, b1; int k, hilflen; if(!m) /* Division durch 0 ohne Fehlermeldung */ return(0); if(m == 1) { a = y[0]; a = modarr(x,n,a); *x = a; return(a ? 1 : 0); } #ifdef M_3264 if(m == 2) { u = big2long(y,m); v = mod4arr(x,n,u); k = long2big(v,x); return(k); } #endif k = n - m; if(k >= 0) cmp = cmparr(x+k,n-k,y,m); if(k < 0 || (k == 0 && cmp < 0)) return(n); /* (y,m) > (x,n) */ else if(k > 0 && cmp < 0) k--; b = bitlen(y[m-1]); b1 = 16 - b; v = (y[m-1] << b1) + (y[m-2] >> b); u = 0xFFFFFFFF; u /= (v + 1); k++; x += k; n -= k; while(--k >= 0) { --x; if(n || *x) n++; if(n >= m) { v = (x[m-1] >> b); if(n > m) /* dann n = m+1 */ v += (x[m] << b1); a = (u*v) >> 16; hilflen = multarr(y,m,a,hilf); n = subarr(x,n,hilf,hilflen); while(cmparr(x,n,y,m) >= 0) n = subarr(x,n,y,m); } } return(n); } /*-------------------------------------------------------------------*/ /* ** Ersetzt (x,n) destruktiv durch -(x,n) mod (y,m) */ PUBLIC int modnegbig(x,n,y,m,hilf) word2 *x, *y, *hilf; int n, m; { int cmp; cmp = cmparr(y,m,x,n); if(cmp == 0) n = 0; else if(cmp < 0) n = modbig(x,n,y,m,hilf); if(n > 0) return sub1arr(x,n,y,m); else return 0; } /*-------------------------------------------------------------------*/ /* ** (zz,ret) = (xx,xlen)*(yy,ylen) mod (mm,mlen) ** TODO: optimize! */ PUBLIC int modmultbig(xx,xlen,yy,ylen,mm,mlen,zz,hilf) word2 *xx,*yy,*mm,*zz,*hilf; int xlen, ylen, mlen; { int len; len = multbig(xx,xlen,yy,ylen,zz,hilf); len = modbig(zz,len,mm,mlen,hilf); return len; } /*-------------------------------------------------------------------*/ #ifdef OLDVERSION /* ** quot = (x,n) / (y,m); Voraussetzung (y,m) != null ** Arbeitet destruktiv auf x; x wird rest, seine Laenge in *rlenptr ** hilf ist Platz fuer Hilfsvariable; muss mindestens m+1 lang sein ** Funktioniert fuer Bestimmung des Restes auch, falls ** Platz quot und Platz hilf gleich sind und der Quotient ** nicht interessiert */ PUBLIC int divbig(x,n,y,m,quot,rlenptr,hilf) word2 *x, *y, *quot, *hilf; int n, m, *rlenptr; { word4 u, v; word2 a; int k, quotlen, hilflen; int cmp, b, b1; if(!m) { /* Division durch 0 ohne Fehlermeldung */ *rlenptr = 0; return(0); } if(m == 1) { quotlen = divarr(x,n,(unsigned)y[0],&a); cpyarr(x,quotlen,quot); *x = a; *rlenptr = (a ? 1 : 0); return(quotlen); } #ifdef M_3264 if(m == 2) { u = big2long(y,m); quotlen = div4arr(x,n,u,&v); cpyarr(x,quotlen,quot); *rlenptr = long2big(v,x); return(quotlen); } #endif k = n - m; if(k >= 0) cmp = cmparr(x+k,n-k,y,m); if(k < 0 || (k == 0 && cmp < 0)) { *rlenptr = n; return(0); } else if(k > 0 && cmp < 0) k--; b = bitlen(y[m-1]); b1 = 16 - b; v = (y[m-1] << b1) + (y[m-2] >> b); u = 0xFFFFFFFF; u /= (v + 1); k++; x += k; n -= k; quot += k; quotlen = k; while(--k >= 0) { --x; if(n || *x) n++; if(n >= m) { v = (x[m-1] >> b); if(n > m) /* dann n = m+1 */ v += (x[m] << b1); a = (u*v) >> 16; hilflen = multarr(y,m,a,hilf); n = subarr(x,n,hilf,hilflen); while(cmparr(x,n,y,m) >= 0) { a++; n = subarr(x,n,y,m); } } else a = 0; *--quot = a; } *rlenptr = n; return(quotlen); } /*-------------------------------------------------------------------*/ #else /* NEWVERSION */ /* ** quot = (x,n) / (y,m); Voraussetzung (y,m) != null ** Arbeitet destruktiv auf x; x wird rest, seine Laenge in *rlenptr ** hilf ist Platz fuer Hilfsvariable; muss mindestens m+1 lang sein ** Funktioniert fuer Bestimmung des Restes auch, falls ** Platz quot und Platz hilf gleich sind und der Quotient ** nicht interessiert */ PUBLIC int divbig(x,n,y,m,quot,rlenptr,hilf) word2 *x, *y, *quot, *hilf; int n, m, *rlenptr; { word4 u, v; word2 a; int k, quotlen, hilflen; int cmp, b, b1; #ifdef M_3264 int kappa, nu, mu; word2 ww[6]; #endif if(!m) { /* Division durch 0 ohne Fehlermeldung */ *rlenptr = 0; return(0); } if(m == 1) { quotlen = divarr(x,n,(unsigned)y[0],&a); cpyarr(x,quotlen,quot); *x = a; *rlenptr = (a ? 1 : 0); return(quotlen); } #ifdef M_3264 if(m == 2) { u = big2long(y,m); quotlen = div4arr(x,n,u,&v); cpyarr(x,quotlen,quot); *rlenptr = long2big(v,x); return(quotlen); } /* else if(m >= 3) */ k = n - m; if(k & 1) k++; /* k must be even */ if(k >= 0) cmp = cmparr(x+k,n-k,y,m); if(k < 0 || (k == 0 && cmp < 0)) { /* (y,m) > (x,n) */ *rlenptr = n; return(0); } else if(cmp >= 0) k += 2; /* now k >= 2 and (x+k,n-k) < (y,m) */ b = bitlen(y[m-1]); b1 = 16 - b; v = y[m-1]; v <<= 16; v += y[m-2]; v <<= b1; v += (y[m-3] >> b); if(v < 0xFFFFFFFF) v++; ww[3] = 0x7FFF; ww[2] = 0xFFFF; ww[1] = 0xFFFF; /* don't care for ww[0] */ nu = div4arr(ww,4,v,&u); v = big2long(ww,nu); b--; for(kappa = k-2; kappa >= 0; kappa -= 2) { mu = m + kappa - 1; if(n <= mu) { quot[kappa] = quot[kappa+1] = 0; continue; } nu = n - mu; cpyarr(x+mu,nu,ww); nu = mult4arr(ww,nu,v,ww); nu = shrarr(ww+2,nu-2,b); u = big2long(ww+2,nu); hilflen = mult4arr(y,m,u,hilf); n = subarr(x+kappa,n-kappa,hilf,hilflen); while(cmparr(x+kappa,n,y,m) >= 0) { u++; n = subarr(x+kappa,n,y,m); } quot[kappa] = (word2)u; quot[kappa+1] = (word2)(u >> 16); if(n == 0) { n = kappa; while(n > 0 && !x[n-1]) n--; } else n += kappa; } *rlenptr = n; if(quot[k-1]) quotlen = k; else if(quot[k-2]) quotlen = k - 1; else quotlen = k - 2; return(quotlen); #else k = n - m; if(k >= 0) cmp = cmparr(x+k,n-k,y,m); if(k < 0 || (k == 0 && cmp < 0)) { *rlenptr = n; return(0); } else if(k > 0 && cmp < 0) k--; b = bitlen(y[m-1]); b1 = 16 - b; v = (y[m-1] << b1) + (y[m-2] >> b); u = 0xFFFFFFFF; u /= (v + 1); k++; x += k; n -= k; quot += k; quotlen = k; while(--k >= 0) { --x; if(n || *x) n++; if(n >= m) { v = (x[m-1] >> b); if(n > m) /* dann n = m+1 */ v += (x[m] << b1); a = (u*v) >> 16; hilflen = multarr(y,m,a,hilf); n = subarr(x,n,hilf,hilflen); while(cmparr(x,n,y,m) >= 0) { a++; n = subarr(x,n,y,m); } } else a = 0; *--quot = a; } *rlenptr = n; return(quotlen); #endif } #endif /* ?OLDVERSION */ /*-------------------------------------------------------------------*/ /* ** Berechnet Produkt von (x,n)*(2^16)^-prec mit (y,m)*(2^16)^-prec ** Ist len der Rueckgabewert so erhaelt man ** Ergebnis = (z,len)*(2^16)^-prec ** Platz z muss Laenge len + prec haben ** Platz hilf muss Laenge m + 1 haben */ PUBLIC int multfix(prec,x,n,y,m,z,hilf) int prec, n, m; word2 *x, *y, *z, *hilf; { int len; if(n+m < prec || !n || !m) return(0); len = multbig(x,n,y,m,z,hilf) - prec; if(len <= 0) return(0); else { cpyarr(z+prec,len,z); return(len); } } /*-------------------------------------------------------------------*/ /* ** Berechnet Quotient von (x,n)*(2^16)^-prec und (y,m)*(2^16)^-prec ** Ist len der Rueckgabewert so erhaelt man ** Ergebnis = (z,len)*(2^16)^-prec ** Platz z muss Laenge len + 1 haben ** Platz hilf muss Laenge n + m + prec + 1 haben */ PUBLIC int divfix(prec,x,n,y,m,z,hilf) int prec, n, m; word2 *x, *y, *z, *hilf; { int i, len; word2 *temp; temp = hilf; hilf += prec + n; setarr(temp,prec,0); cpyarr(x,n,temp+prec); len = divbig(temp,prec+n,y,m,z,&i,hilf); return(len); } /*------------------------------------------------------------------*/ PUBLIC unsigned shortgcd(x,y) unsigned x, y; { unsigned r; while(y) { r = x % y; x = y; y = r; } return(x); } /*------------------------------------------------------------------*/ /* ** bestimmt den gcd von (x,n) und (y,m), Resultat in x ** arbeitet destruktiv auf x und y */ PUBLIC int biggcd(x,n,y,m,hilf) word2 *x, *y, *hilf; int n, m; { int rlen; word2 *savex, *temp; savex = x; while(m > 0) { rlen = modbig(x,n,y,m,hilf); temp = x; x = y; n = m; y = temp; m = rlen; } if(savex != x) cpyarr(x,n,savex); return(n); } /*-------------------------------------------------------------------*/ /* ** p = (x,n) hoch a ** temp und hilf sind Plaetze fuer Hilfsvariable, ** muessen so gross wie das Resultat p sein */ PUBLIC int power(x,n,a,p,temp,hilf) word2 *x, *p, *temp, *hilf; int n; unsigned a; { int plen; unsigned mask, b; if(a == 0) { p[0] = 1; return(1); } else if(n == 0) return(0); cpyarr(x,n,p); plen = n; if((b = (a >> 16))) { mask = 0x8000; mask <<= bitlen(b); } else { mask = 1 << (bitlen(a)-1); } while(mask >>= 1) { plen = multbig(p,plen,p,plen,temp,hilf); if(a & mask) { plen = multbig(temp,plen,x,n,p,hilf); } else cpyarr(temp,plen,p); } return(plen); } /*-------------------------------------------------------------------*/ /* ** Berechnet groesste ganze Zahl z mit z*z <= x ** Arbeitet destruktiv auf x, x wird rest, seine Laenge in *rlenp ** Platz x muss mindestens n+1 lang sein, ** Platz z um eins groesser als die Wurzel, ** Platz temp um 2 groesser als die Wurzel */ PUBLIC int bigsqrt(x,n,z,rlenp,temp) word2 *x, *z, *temp; int n; int *rlenp; { int sh, len, restlen, templen; word4 v, vv, rr; unsigned xi; if(n <= 2) { v = big2long(x,n); v = intsqrt(v); return(long2big(v,z)); } sh = (n&1 ? 8 : 0); sh += (16 - bitlen(x[n-1])) >> 1; n = shiftarr(x,n,sh+sh); /* n is always even */ x += n - 2; rr = big2long(x,2); v = intsqrt(rr); restlen = long2big(rr-v*v,x); len = n >> 1; setarr(z,len-1,0); z += len - 1; z[0] = v; n = incarr(z,1,(unsigned)v); vv = v << 16; while(--len > 0) { z--; n++; x -= 2; restlen += 2; if(restlen == 2) { while(restlen > 0 && x[restlen-1] == 0) restlen--; } if(restlen < n) continue; rr = big2long(x+n-2,2) >> 1; if(restlen > n) /* dann x[restlen-1] = 1 */ rr += 0x80000000; if(rr >= vv) xi = 0xFFFF; else xi = rr / v; n = incarr(z,n,xi); templen = multarr(z,n,xi,temp); n = incarr(z,n,xi); while(cmparr(x,restlen,temp,templen) < 0) { n = decarr(z,n,1); templen = subarr(temp,templen,z,n); n = decarr(z,n,1); } restlen = subarr(x,restlen,temp,templen); while(cmparr(x,restlen,z,n) > 0) { n = incarr(z,n,1); restlen = subarr(x,restlen,z,n); n = incarr(z,n,1); } } *rlenp = shiftarr(x,restlen,-sh-sh); return(shiftarr(z,n,-sh-1)); } /*-------------------------------------------------------------------*/ /* ** bestimmt Laenge in Bits einer 32-Bit-Zahl x ** 0 <= bitlen <= 32; bitlen = 0 <==> x == 0; */ PUBLIC int lbitlen(x) word4 x; { unsigned x0; if(x >= 0x10000) { x0 = x >> 16; return(16 + bitlen(x0)); } else { x0 = x; return(bitlen(x0)); } } /*-------------------------------------------------------------------*/ /* ** berechnet Nibble k (0 <= k <= 3) einer 16-Bit-Zahl x */ PRIVATE unsigned nibble(x,k) unsigned x; int k; { k <<= 2; x >>= k; return(x & 0x000F); } /*-------------------------------------------------------------------*/ /* ** verwandelt Array von bcd-Zahlen (x,n) in big-Array y; ** n ist Anzahl der word2-Stellen von x ** Rueckgabewert Laenge von y. */ PUBLIC int bcd2big(x,n,y) word2 *x, *y; int n; { int m; if(!n) return(0); x += n; y[0] = bcd2int(*--x); m = 1; while(--n > 0) { m = multarr(y,m,DECBASE,y); m = incarr(y,m,bcd2int(*--x)); } return(m); } /*-------------------------------------------------------------------*/ #ifdef NAUSKOMM /********* not used *********/ /* ** verwandelt String in Array von bcd-Zahlen; ** Rueckgabewert Anzahl der Ziffern */ PRIVATE int str2bcd(str,arr) char *str; word2 *arr; { int n = str2barr(str,4,arr); return(n ? ((n-1)<<2) + niblen(arr[n-1]) : 0); } #endif /*-------------------------------------------------------------------*/ PUBLIC int str2int(str,panz) char *str; int *panz; { int i,x; int ch; for(i=0,x=0; isdecdigit(ch = *str); i++,str++) x = x * 10 + (ch - '0'); *panz = i; return(x); } /*-------------------------------------------------------------------*/ /* ** verwandelt String str in big-integer arr ** Rueckgabewert Laenge von arr ** Platz hilf muss strlen(str)/2 + 1 lang sein */ PUBLIC int str2big(str,arr,hilf) char *str; word2 *arr, *hilf; { int n; n = str2barr(str,4,hilf); n = bcd2big(hilf,n,arr); return(n); } /*-------------------------------------------------------------------*/ /* ** verwandelt Array (arr,n) von bcd-Zahlen in String; ** Rueckgabewert Stringlaenge */ PUBLIC int bcd2str(arr,n,str) word2 *arr; int n; char *str; { int i = n; if(n == 0) { *str++ = '0'; *str = 0; return(1); } while(--i >= 0) *str++ = nibascii(arr,i); *str = 0; return(n); } /*-------------------------------------------------------------------*/ PUBLIC int big2xstr(arr,n,str) word2 *arr; int n; char *str; { n = (n ? (n-1)*4 + niblen(arr[n-1]) : 0); return(bcd2str(arr,n,str)); } /*-------------------------------------------------------------------*/ /* ** ch muss ein hex-Character sein */ PUBLIC int digval(ch) int ch; { if(ch >= '0' && ch <= '9') return(ch - '0'); else if(ch >= 'A' && ch <= 'Z') return(ch - 'A' + 10); else return(ch - 'a' + 10); } /*-------------------------------------------------------------------*/ /* */ PRIVATE int str2barr(str,b,arr) char *str; int b; /* bits per digit: 1=bin, 3=oct, 4=hex */ word2 *arr; { int n, i, k, m, len = 0; unsigned dig; while(*str == '0') str++; while(*str++) len++; --str; /* jetzt zeigt str auf '\0' */ n = (len*b + 15) >> 4; setarr(arr,n,0); for(i=0; --len>=0; i+=b) { dig = digval(*--str); k = i >> 4; m = i & 0xF; arr[k] += (dig << m); if(m+b > 16) arr[k+1] += (dig >> (16-m)); } return(n); } /*-------------------------------------------------------------------*/ /* ** Verwandelt String in bignum (arr,n); n ist Rueckgabewert. */ PUBLIC int xstr2big(str,arr) char *str; word2 *arr; { return(str2barr(str,4,arr)); } /*-------------------------------------------------------------------*/ PUBLIC int ostr2big(str,arr) char *str; word2 *arr; { return(str2barr(str,3,arr)); } /*-------------------------------------------------------------------*/ PUBLIC int bstr2big(str,arr) char *str; word2 *arr; { return(str2barr(str,1,arr)); } /*-------------------------------------------------------------------*/ /* ** gibt k-te Dezimalstelle des bcd-Arrays arr; ** 0 <= k < Stellenzahl von arr */ PUBLIC int nibdigit(arr,k) word2 *arr; int k; { return(nibble(arr[k>>2],k&3)); } /*-------------------------------------------------------------------*/ /* ** Das Array arr wird als Folge von Nibbles zu je n bit (n=1,3,4) ** aufgefasst. Die Funktion gibt das k-te Nibble zurueck. ** Vorsicht! Die gueltige Laenge von arr ist nicht bekannt. */ PUBLIC int nibndigit(n,arr,k) int n; /* bits per digit */ word2 *arr; long k; { int x, i; long k3; if(n == 4) return(nibdigit(arr,(int)k)); else if(n == 1) return(nthbit(arr,k)); else if(n == 3) { k3 = k+k+k; x = 0; for(i=2; i>=0; i--) { x <<= 1; if(nthbit(arr,k3+i)) x |= 1; } return(x); } else /* this case should not happen */ return(0); } /*-------------------------------------------------------------------*/ PRIVATE int nthbit(arr,n) word2 *arr; long n; /* zero based */ { int k, b; word2 mask = 1; k = n >> 4; b = n & 0xF; return(arr[k] & (mask << b) ? 1 : 0); } /*-------------------------------------------------------------------*/ /* ** gibt Ascii-code der k-ten Dezimalstelle des bcd-Arrays arr; ** 0 <= k < Stellenzahl von arr */ PUBLIC int nibascii(arr,k) word2 *arr; int k; { return(hexascii(nibdigit(arr,k))); } /*-------------------------------------------------------------------*/ PUBLIC int hexascii(n) int n; { if(0 <= n && n <= 9) return('0' + n); else if(n >= 10 && n <= 15) return(('A'-10) + n); else /* this case should not happen */ return('0'); } /*-------------------------------------------------------------------*/ /* ** verschiebt bcd-array (arr,n) um k Stellen ** k > 0: Links-Shift; k < 0: Rechts-Shift ** Rueckgabewert: Anzahl der Dezimal-Stellen */ PUBLIC int shiftbcd(arr,n,k) word2 *arr; int n, k; { int b, len; if(-k >= n) return(0); b = k<<2; len = (n + 3)>>2; len = shiftarr(arr,len,b); return(n + k); } /*-------------------------------------------------------------------*/ PUBLIC int incbcd(x,n,a) word2 *x; int n; unsigned a; { int i, len; unsigned u; if(a == 0) return(n); len = (n + 3)>>2; for(i=0; a && i>4] |= (1 << ((i)&0xF)) #define testbit(vv,i) (vv[(i)>>4] & (1 << ((i)&0xF))) /*-------------------------------------------------------------------*/ PUBLIC int prime16 (unsigned u); PUBLIC int prime32 (word4 u); PUBLIC unsigned fact16 (word4 u); PUBLIC unsigned trialdiv (word2 *x, int n, unsigned u0, unsigned u1); PUBLIC int jacobi (int sign, word2 *x, int n, word2 *y, int m, word2 *hilf); PUBLIC int jac (unsigned x, unsigned y); PUBLIC int rabtest (word2 *x, int n, word2 *aux); PUBLIC int nextprime32 (word4 u, word2 *x); PUBLIC int pemult (word2 *x, int n, word2 *ex, int exlen, word2 *aa, int alen, word2 *mm, int modlen, word2 *z, word2 *hilf); PUBLIC int modinverse (word2 *x, int n, word2 *y, int m, word2 *zz, word2 *hilf); PUBLIC int modinv (int x, int mm); PUBLIC int modpower (word2 *x, int n, word2 *ex, int exlen, word2 *mm, int modlen, word2 *p, word2 *hilf); PUBLIC unsigned modpow (unsigned x, unsigned n, unsigned mm); PRIVATE void primsiev (word2 *vect, int n); PRIVATE truc Fjacobi (void); PRIVATE truc Ffact16 (int argn); PRIVATE truc Fprime32 (void); PRIVATE truc Frabtest (void); PRIVATE int rabtest0 (word2 *x, int n, unsigned u, word2 *aux); PRIVATE truc Fnextprime (int argn); PRIVATE truc Fgcd (int argn); PRIVATE unsigned gcdfixnums (truc *argptr, int argn); PRIVATE int gcdbignums (word2 *x, word2 *y, truc *argptr, int argn); PRIVATE truc Fmodinv (void); PRIVATE truc Sgcdx (void); PRIVATE int gcdcx (word2 *x, int n, word2 *y, int m, word2 *cx, int *cxlptr, word2 *hilf); PRIVATE int gcdcxcy (word2 *x1, int n1, word2 *x, int n, word2 *y,int m, word2 *cx, int cxlen, word2 *cy, word2 *hilf); PRIVATE truc Fmodpower (int argn); PRIVATE truc Fcoshmult (int argn); PRIVATE int coshmult (word2 *x, int n, word2 *ex, int exlen, word2 *mm, int modlen, word2 *z, word2 *hilf); PRIVATE truc Fpemult (int argn); PRIVATE truc Ffactorial (void); PRIVATE int factorial (unsigned a, word2 *x); PRIVATE truc jacobsym, gcdsym, gcdxsym, modinvsym; PRIVATE truc factorsym, primsym, rabtestsym; PRIVATE truc nxtprimsym; PRIVATE truc pemultsym, cshmultsym; PRIVATE truc factsym; /*------------------------------------------------------------------*/ PUBLIC void iniaritx() { modpowsym = newintsym("** mod", sFBINARY,(wtruc)Fmodpower); gcdsym = newsymsig("gcd",sFBINARY,(wtruc)Fgcd, s_0uii); gcdxsym = newsymsig("gcdx",sSBINARY,(wtruc)Sgcdx, s_iiiII); modinvsym = newsymsig("mod_inverse",sFBINARY,(wtruc)Fmodinv, s_iii); jacobsym = newsymsig("jacobi", sFBINARY, (wtruc)Fjacobi, s_iii); primsym = newsymsig("prime32test",sFBINARY,(wtruc)Fprime32,s_ii); rabtestsym= newsymsig("rab_primetest",sFBINARY,(wtruc)Frabtest,s_1); nxtprimsym= newsymsig("next_prime",sFBINARY,(wtruc)Fnextprime, s_12); factorsym = newsymsig("factor16",sFBINARY,(wtruc)Ffact16, s_13); pemultsym = newsymsig("mod_pemult",sFBINARY,(wtruc)Fpemult, s_Viiii); cshmultsym= newsymsig("mod_coshmult",sFBINARY,(wtruc)Fcoshmult, s_iiii); factsym = newsymsig("factorial", sFBINARY, (wtruc)Ffactorial,s_ii); primsiev(PrimTab,PRIMTABSIZE); } /*-------------------------------------------------------------------*/ /* ** Setzt im Bit-Vektor vect der Laenge n*16 bit (8 <= n <= 2096) ** das bit i, falls 2*i + 1 eine Primzahl ist */ PRIVATE void primsiev(vect,n) word2 *vect; int n; { word2 mask[16]; unsigned i, k, inc; for(i=0; i<16; i++) mask[i] = ~(1 << i); setarr(vect,n,0xFFFF); n <<= 4; /* mal 16 */ vect[0] &= 0xFFFE; /* da 1 keine Primzahl */ for(i=1; i<128; i++) { /* Zahlen 3 bis 255 */ if(testbit(vect,i)) { /* falls 2*i + 1 Primzahl */ inc = i + i + 1; for(k=i+inc; k> 4] &= mask[k & 0xF]; } } } /*-------------------------------------------------------------------*/ /* ** Stellt fest, ob die 16-bit-Zahl u prim ist */ PUBLIC int prime16(u) unsigned u; { if(!(u & 1)) return(u == 2); u >>= 1; if(testbit(PrimTab,u)) return(1); else return(0); } /*-------------------------------------------------------------------*/ /* ** Rueckgabewert 1, falls u Primzahl ist, sonst 0 */ PUBLIC int prime32(u) word4 u; { unsigned mask, v, p; word2 *pbits; if(u <= 0xFFFF) return(prime16((unsigned)u)); else if(!(u & 1)) return(0); v = intsqrt(u); pbits = PrimTab; mask = 2; for(p=3; p<=v; p += 2) { if((*pbits & mask) && (u % p == 0)) return(0); mask <<= 1; if((mask & 0xFFFF) == 0) { pbits++; mask = 1; } } return(1); } /*-------------------------------------------------------------------*/ /* ** Rueckgabewert 0, falls u Primzahl ist, ** sonst kleinster Primteiler */ PUBLIC unsigned fact16(u) word4 u; { unsigned mask, v, p; word2 *pbits; if(!(u & 1)) return(2); v = intsqrt(u); pbits = PrimTab; mask = 2; for(p=3; p<=v; p += 2) { if((*pbits & mask) && (u % p == 0)) return(p); mask <<= 1; if((mask & 0xFFFF) == 0) { pbits++; mask = 1; } } return(0); } /*------------------------------------------------------------------*/ PUBLIC int nextprime32(u,x) word4 u; word2 *x; { int n; if(u <= 2) { *x = 2; return(1); } else if(u <= 0xFFFFFFFB) { if((u & 1) == 0) u++; while(prime32(u) == 0) u += 2; n = long2big(u,x); return(n); } else { /* p = 2**32 + 15 */ x[0] = 0xF; x[1] = 0; x[2] = 1; return(3); } } /*------------------------------------------------------------------*/ PRIVATE truc Fnextprime(argn) int argn; { #define ANZRAB 10 truc *argptr; word2 *x; word4 u; int compos; int i, n, sign; int doreport; argptr = argStkPtr-argn+1; if(argn >= 2 && *argStkPtr == zero) { doreport = 0; argn--; } else { doreport = 1; } n = bigref(argptr,&x,&sign); if(n == aERROR) { error(nxtprimsym,err_int,*argptr); return(brkerr()); } if(n >= aribufSize/9) { error(nxtprimsym,err_int,*argStkPtr); return(brkerr()); } if(n <= 2) { u = big2long(x,n); n = nextprime32(u,AriBuf); } else { cpyarr(x,n,AriBuf); x = AriBuf; if((x[0] & 1) == 0) x[0]++; compos = 1; if(doreport) workmess(); while(compos) { while(trialdiv(x,n,3,0xFFFB)) n = incarr(x,n,2); for(compos=0,i=0; i= 1) { while((x[0] & 1) == 0) { n = shrarr(x,n,1); m8 = y[0] & 0x7; if(m8 == 3 || m8 == 5) res = -res; } if(*x == 1 && n == 1) return(res); temp = x; tlen = n; x = y; n = m; y = temp; m = tlen; if((x[0] & 2) && (y[0] & 2)) /* beide = 3 mod 4 */ res = -res; n = modbig(x,n,y,m,hilf); } return(0); } /*-------------------------------------------------------------------*/ /* ** Version von jacobi fuer kleine nichtnegative integers ** y muss ungerade sein */ PUBLIC int jac(x,y) unsigned x, y; { int res = 1; int m8; unsigned temp; while(x >= 1) { while((x & 1) == 0) { x >>= 1; m8 = y & 0x7; if(m8 == 3 || m8 == 5) res = -res; } if(x == 1) return(res); if((x & 2) && (y & 2)) /* beide = 3 mod 4 */ res = -res; temp = x; x = y % temp; y = temp; } return(0); } /*------------------------------------------------------------------*/ PRIVATE truc Ffactorial() { int n; word2 a; if(*FLAGPTR(argStkPtr) != fFIXNUM || *SIGNPTR(argStkPtr)) { error(factsym,err_pfix,*argStkPtr); return(brkerr()); } a = *WORD2PTR(argStkPtr); if(a <= 1) return(constone); if(bitlen(a) > maxfltex/a + 1) { error(factsym,err_ovfl,voidsym); return(brkerr()); } n = factorial(a,AriBuf); return(mkint(0,AriBuf,n)); } /*------------------------------------------------------------------*/ /* ** Hypothesis: a > 1 ** The factorial of a is stored in x (which must be large enough), ** its length is returned */ PRIVATE int factorial(a,x) unsigned a; word2 *x; { #ifdef M_3264 word4 u; #endif unsigned small = 718; unsigned i, k, b; int len, sh; if(a & 1) { x[0] = a; a--; } else x[0] = 1; len = 1; #ifdef M_3264 if(!(a & 2)) { u = a; u *= a-1; len = mult4arr(x,len,u,x); a -= 2; } /* now a = 2 mod 4 */ b = (a <= small ? a : small); for(i=3, k=b>>1; i>1)+1; i>1; i>1)+1; i> 1; len = shiftarr(x,len,sh); return(len); } /*------------------------------------------------------------------*/ PRIVATE truc Ffact16(argn) int argn; /* 1 <= argn <= 3 */ { truc *argptr; word2 *x; unsigned u; unsigned u0 = 2, u1 = 0xFFF1; /* largest prime <= 0xFFFF */ int n, sign, flg; argptr = argStkPtr - argn + 1; if(chkints(factorsym,argptr,argn) == aERROR) return(brkerr()); n = bigref(argptr,&x,&sign); if(argn >= 2) { argptr++; flg = *FLAGPTR(argptr); if(flg != fFIXNUM) return(zero); else u0 = *WORD2PTR(argptr); } if(argn >= 3 && *FLAGPTR(argStkPtr) == fFIXNUM) u1 = *WORD2PTR(argStkPtr); u = trialdiv(x,n,u0,u1); return(mkfixnum(u)); } /*------------------------------------------------------------------*/ PRIVATE truc Fprime32() { word4 u; word2 *x; int sign, n, res; n = bigref(argStkPtr,&x,&sign); if(n == aERROR) { error(primsym,err_int,*argStkPtr); return(brkerr()); } if(n > 2) res = -1; else { u = big2long(x,n); res = prime32(u); } return(mksfixnum(res)); } /*-------------------------------------------------------------------*/ /* ** Probedivision von (x,n) durch 16-bit Primzahlen ** zwischen u0 >= 2 und u1 <= (x,n)/2 ** Der erste Teiler wird zurueckgegeben; ** falls keiner gefunden, Rueckgabewert 0 */ PUBLIC unsigned trialdiv(x,n,u0,u1) word2 *x; int n; unsigned u0, u1; { extern word2 *PrimTab; word2 *pbits; unsigned u, mask = 1; u = x[0]; if(n == 1) { if(prime16(u)) return(0); else if(u1 > (u >> 1)) u1 = (u >> 1); } if(u1 > 0xFFF1) u1 = 0xFFF1; /* largest prime <= 0xFFFF */ if(u0 > u1 || u1 < 2 || !n) return(0); if(u0 <= 2 && !(u & 1)) return(2); u0 >>= 1; pbits = PrimTab + (u0 >> 4); mask <<= (u0 & 0xF); for(u = 2*u0 + 1; u <= u1; u += 2) { if((*pbits & mask) && (modarr(x,n,u) == 0)) return(u); mask <<= 1; if((mask & 0xFFFF) == 0) { pbits++; mask = 1; } } return(0); } /*------------------------------------------------------------------*/ /* ** Strong-Pseudo-Primzahltest nach Rabin */ PRIVATE truc Frabtest() { /* ** TODO: optional argument base */ word2 *x; int sign, n; unsigned u; n = bigref(argStkPtr,&x,&sign); if(n == aERROR) { error(rabtestsym,err_int,*argStkPtr); return(brkerr()); } if(n == 0) return(false); else if(n <= 2) { return(prime32(big2long(x,n)) > 0 ? true : false); } else if((x[0] & 1) == 0) return(false); else if(n < scrbufSize/9 && n < aribufSize/2) { u = 2 + random2(64000); return(rabtest0(x,n,u,AriScratch) ? true : false); } else { error(rabtestsym,err_ovfl,*argStkPtr); return(brkerr()); } } /*------------------------------------------------------------------*/ /* ** Puffer aux muss mindestens 8*n + 2 lang sein. ** u is a positive integer < 2**16 */ PRIVATE int rabtest0(x,n,u,aux) word2 *x, *aux; unsigned u; int n; { word2 *base, *ex, *y, *x1, *hilf; int exlen, ylen, n1; int i, t; base = aux; y = aux + n; x1 = y + 2*n; ex = x1 + n; hilf = ex + n; base[0] = u; cpyarr(x,n,x1); n1 = decarr(x1,n,1); cpyarr(x1,n1,ex); exlen = n1; t = 0; while((ex[0] & 1) == 0) { t++; exlen = shrarr(ex,exlen,1); } ylen = modpower(base,1,ex,exlen,x,n,y,hilf); if((ylen == 1 && y[0] == 1) || (cmparr(y,ylen,x1,n1) == 0)) { return(1); } /* else */ ex[0] = 2; exlen = 1; for(i=1; i= fFIXNUM) { argn = *VECLENPTR(argStkPtr); argptr = VECTORPTR(argStkPtr); } else return brkerr(); } else { /* argn > 0 */ argptr = argStkPtr - argn + 1; flg = chkints(gcdsym,argptr,argn); } if(flg == fFIXNUM) { u = gcdfixnums(argptr,argn); return(mkfixnum(u)); } else if(flg == fBIGNUM) { n = gcdbignums(AriBuf,AriScratch,argptr,argn); return(mkint(0,AriBuf,n)); } else return brkerr(); } /*------------------------------------------------------------------*/ PRIVATE unsigned gcdfixnums(argptr,argn) truc *argptr; int argn; /* argn > 0 */ { unsigned x; x = *WORD2PTR(argptr++); while(--argn > 0) { x = shortgcd(x,*WORD2PTR(argptr++)); if(x == 1) break; } return(x); } /*------------------------------------------------------------------*/ PRIVATE int gcdbignums(x,y,argptr,argn) word2 *x, *y; truc *argptr; int argn; /* argn > 0 */ { word2 *hilf; int n, m, sign; n = bigretr(argptr++,x,&sign); while(--argn > 0) { m = bigretr(argptr++,y,&sign); if(m == 0) continue; hilf = y + m; n = biggcd(x,n,y,m,hilf); if(*x == 1 && n == 1) break; } return(n); } /*-------------------------------------------------------------------*/ PRIVATE truc Fmodinv() { word2 *x, *y; int n, m, bound, len; int sign1, sign2; if(chkints(modinvsym,argStkPtr-1,2) == aERROR) { return(brkerr()); } n = bigref(argStkPtr-1,&x,&sign1); m = bigref(argStkPtr,&y,&sign2); if(n == 0 || m == 0) { return(zero); } bound = (aribufSize >> 1) - 2; if((n >= bound) || (m >= bound)) { error(modinvsym,err_ovfl,voidsym); return(brkerr()); } len = modinverse(x,n,y,m,AriBuf,AriScratch); if(len == 0) /* not relatively prime */ return(zero); else if(sign1) len = sub1arr(AriBuf,len,y,m); return(mkint(0,AriBuf,len)); } /*-------------------------------------------------------------------*/ PRIVATE truc Sgcdx() { truc res; word2 *x, *y, *cx, *cy, *x1; int n, m, N, cxlen, cylen, n1; int sign1, sign2; int flg; res = eval(ARGNPTR(evalStkPtr,1)); ARGpush(res); res = eval(ARGNPTR(evalStkPtr,2)); ARGpush(res); flg = chkints(gcdxsym,argStkPtr-1,2); if(flg == aERROR) { res = brkerr(); goto cleanup; } x1 = AriBuf; n = bigref(argStkPtr-1,&x,&sign1); m = bigref(argStkPtr,&y,&sign2); N = (n >= m ? n : m) + 2; if(N >= aribufSize/3 || N >= scrbufSize/10) { error(gcdxsym,err_ovfl,voidsym); return(brkerr()); } cpyarr(x,n,x1); cx = x1 + N; cy = cx + N; if(n && m) { n1 = gcdcx(x1,n,y,m,cx,&cxlen,AriScratch); cylen = gcdcxcy(x1,n1,x,n,y,m,cx,cxlen,cy,AriScratch); if(cxlen) sign2 = (sign2 ? 0 : MINUSBYTE); } else if(n) { /* x != 0, y == 0 */ n1 = n; cx[0] = 1; cxlen = 1; cylen = 0; } else if(m) { /* x == 0, y != 0 */ n1 = m; cpyarr(y,m,x1); cxlen = 0; cy[0] = 1; cylen = 1; } else { /* x == 0, y == 0 */ n1 = cxlen = cylen = 0; } Lvalassign(ARGNPTR(evalStkPtr,3),mkint(sign1,cx,cxlen)); Lvalassign(ARGNPTR(evalStkPtr,4),mkint(sign2,cy,cylen)); res = mkint(0,x1,n1); cleanup: ARGnpop(2); return(res); } /*-------------------------------------------------------------------*/ /* ** Berechnet den GGT von (x,n) und (y,m), destruktiv auf x ** Es wird vorausgesetzt, dass (y,m) ungleich Null. ** x wird durch den GGT ersetzt, seine Laenge ist der Rueckgabewert. ** y wird nicht beruehrt ** Ausserdem wird in (cx, *cxlptr) ein Koeffizient abgelegt, ** so dass (x,n) * (cx,*cxlptr) = GGT mod (y,m). ** Falls (x,n) = 0, wird (y,m) auf Platz x kopiert! ** Platz hilf muss 5 * max(n,m) + 10 lang sein */ PRIVATE int gcdcx(x,n,y,m,cx,cxlptr,hilf) word2 *x, *y, *cx, *hilf; int n, m; int *cxlptr; { word2 *q, *x1, *x2, *alfa, *beta, *prod, *temp; int n1, n2, N, qlen, rlen, alen, blen, plen, tlen; int count; N = (n > m ? n + 2 : m + 2); beta = cx; x1 = hilf; q = hilf + N; alfa = hilf + 2*N; prod = hilf + 3*N; hilf += 4*N; if(m == 0) { return(0); } n2 = modbig(x,n,y,m,hilf); if(n2 == 0) { cpyarr(y,m,x); *cxlptr = 0; return(m); } x2 = x; cpyarr(y,m,x1); n1 = m; alen = 0; blen = 1; beta[0] = 1; /* ** Schleifeninvarianten: ** (x1,n1) = -+(alfa,alen)*(x,n) mod (y,m) ** (x2,n2) = +-(beta,blen)*(x,n) mod (y,m) */ count = 0; while(qlen = divbig(x1,n1,x2,n2,q,&rlen,hilf), rlen) { count++; /* x1neu = x2alt, x2neu = rest */ temp = x1; x1 = x2; n1 = n2; x2 = temp; n2 = rlen; plen = multbig(beta,blen,q,qlen,prod,hilf); /* alfaneu = betaalt, betaneu = alfaalt + q*betaalt */ temp = alfa; tlen = alen; alfa = beta; alen = blen; beta = temp; blen = addarr(beta,tlen,prod,plen); } /****** not optimal, keep sign! *****/ if(count & 1) blen = sub1arr(beta,blen,y,m); /***********/ if(beta != cx) cpyarr(beta,blen,cx); *cxlptr = blen; if(x2 != x) cpyarr(x2,n2,x); return(n2); } /*------------------------------------------------------------------*/ /* ** Berechnet das Inverse von (x,n) modulo (y,m) ** Resultat wird in zz abgelegt, seine Laenge ist Rueckgabewert. ** x und y bleiben erhalten ** Falls x und y nicht teilerfremd, wird 0 zurueckgegeben. ** Platz hilf muss genuegend lang sein, 6 * max(n,m) + 12 */ PUBLIC int modinverse(x,n,y,m,zz,hilf) word2 *x, *y, *zz, *hilf; int n, m; { word2 *xx; int N, k, len; N = (n > m ? n + 2 : m + 2); xx = hilf; hilf += N; cpyarr(x,n,xx); k = gcdcx(xx,n,y,m,zz,&len,hilf); if((k != 1) || (xx[0] != 1)) return(0); else return(len); } /*---------------------------------------------------------------*/ /* ** Calculates inverse of x mod mm ** If x is not invertible mod mm, then 0 is returned */ PUBLIC int modinv(x,mm) int x,mm; { int y, yold, q, q1, q2, q2old; q1 = 1; q2 = 0; y = mm; while(y) { yold = y; q = x / y; y = x % y; x = yold; q2old = q2; q2 = q1 - q*q2; q1 = q2old; } if(x == 1) { return (q1 >= 0 ? q1 : mm+q1); } else return 0; } /*------------------------------------------------------------------*/ /* ** Berechnet den Koeffizienten cy fuer die Darstellung ** x1 = cx * x - cy * y. ** x, y, x1 und cx sind vorgegeben. ** Falls cx = 0, wird x1 = cy * y. ** Dabei wird vorausgesetzt, dass y /= 0 und x1 der GGT von x und y ist. ** Die Laenge von cy ist der Rueckgabewert. */ PRIVATE int gcdcxcy(x1,n1,x,n,y,m,cx,cxlen,cy,hilf) word2 *x1, *x, *y, *cx, *cy, *hilf; int n1, n, m, cxlen; { word2 *temp; int tlen, len, rlen; temp = hilf; hilf += n + cxlen + 2; if(cxlen) { tlen = multbig(x,n,cx,cxlen,temp,hilf); tlen = subarr(temp,tlen,x1,n1); } else { cpyarr(x1,n1,temp); tlen = n1; } len = divbig(temp,tlen,y,m,cy,&rlen,hilf); return(len); } /*------------------------------------------------------------------*/ /* ** Base ** Ex mod Modulus */ PRIVATE truc Fmodpower(argn) int argn; { word2 *x, *y, *z, *hilf; int n, n1, n2, n3; int sign1, sign2, sign3; if(chkints(modpowsym,argStkPtr-2,3) == aERROR) return(brkerr()); x = AriScratch; hilf = AriScratch + aribufSize; n1 = bigretr(argStkPtr-2,x,&sign1); n2 = bigref(argStkPtr-1,&y,&sign2); n3 = bigref(argStkPtr,&z,&sign3); if(!n3) { error(modpowsym,err_div,voidsym); return(brkerr()); } /* overflow? */ n = (n3 > n1 ? n3 : n1) + 3; if (n >= aribufSize/2 || n + aribufSize/3 >= scrbufSize/3) { error(modpowsym,err_ovfl,voidsym); return(brkerr()); } if(sign2) { if(n1) n1 = modinverse(x,n1,z,n3,AriBuf,hilf); if(!n1) { error(modpowsym,err_div,voidsym); return(brkerr()); } if(n2 == 1 && y[0] == 1) { n = n1; goto testsigns; } else { cpyarr(AriBuf,n1,x); } } n = modpower(x,n1,y,n2,z,n3,AriBuf,hilf); if(n == 0) return zero; /* else */ if(n2 == 0) sign1 = 0; else if((*y & 1) == 0) sign1 = 0; testsigns: if(sign1 != sign3) n = sub1arr(AriBuf,n,z,n3); return(mkint(sign3,AriBuf,n)); } /*-------------------------------------------------------------------*/ /* ** p = (x,n) hoch (ex,exlen) modulo (mm,modlen) ** (x,n) wird destruktiv modulo (mm,modlen) reduziert ** Der Puffer fuer p muss mindestens 2*modlen lang sein ** hilf ist Platz fuer Hilfsvariable, ** muss (2*modlen + max(n,modlen) + 2) lang sein. */ PUBLIC int modpower(x,n,ex,exlen,mm,modlen,p,hilf) word2 *x, *ex, *mm, *p, *hilf; int n, exlen, modlen; { word2 *temp; int k, plen; int allowintr; temp = hilf + 2*modlen + 2; if(exlen == 0) { p[0] = 1; return(1); } n = modbig(x,n,mm,modlen,hilf); if(n == 0) return(0); cpyarr(x,n,p); plen = n; /* plen <= modlen */ k = ((exlen-1) << 4) + bitlen(ex[exlen-1]) - 1; allowintr = (modlen >= 16 && (k/16 + modlen >= 256) ? 1 : 0); while(--k >= 0) { plen = multbig(p,plen,p,plen,temp,hilf); cpyarr(temp,plen,p); plen = modbig(p,plen,mm,modlen,hilf); if(testbit(ex,k)) { plen = multbig(p,plen,x,n,temp,hilf); cpyarr(temp,plen,p); plen = modbig(p,plen,mm,modlen,hilf); } if(allowintr && INTERRUPT) { setinterrupt(0); reset(err_intr); } } return(plen); } /*---------------------------------------------------------------*/ /* ** Calculates x**n mod mm ** mm must be < 2**16 */ PUBLIC unsigned modpow(x,n,mm) unsigned x,n,mm; { word4 u,z; if(n == 0) return(1); z = 1; u = x % mm; while(n > 1) { if(n & 1) z = (z*u) % mm; u = (u*u) % mm; n >>= 1; } return((z*u) % mm); } /*------------------------------------------------------------------*/ /* ** mod_coshmult(Base,Exponent,Module) */ PRIVATE truc Fcoshmult(argn) int argn; /* argn = 3 */ { word2 *x, *y, *z, *res, *hilf; int len, n1, n2, n3; int sign1, sign; if(chkints(cshmultsym,argStkPtr-2,3) == aERROR) return(brkerr()); x = AriScratch; res = AriBuf; hilf = AriScratch + aribufSize; n1 = bigretr(argStkPtr-2,x,&sign1); n2 = bigref(argStkPtr-1,&y,&sign); n3 = bigref(argStkPtr,&z,&sign); if(!n3) { error(cshmultsym,err_div,voidsym); return(brkerr()); } len = coshmult(x,n1,y,n2,z,n3,res,hilf); return(mkint(0,res,len)); } /*------------------------------------------------------------------*/ /* ** Berechnet z = cosh(ex*xi) modulo mm, wobei x = cosh(xi). ** z = v(ex) berechnet sich durch folgende Rekursion: ** v(0) = 1; v(1) = x; ** v(2*n) = 2*v(n)*v(n) - 1; ** v(2*n+1) = 2*v(n+1)*v(n) - x. */ PRIVATE int coshmult(x,n,ex,exlen,mm,modlen,z,hilf) word2 *x, *ex, *mm, *z, *hilf; int n, exlen, modlen; { word2 *v, *w, *u, *temp; int k, vlen, wlen, ulen, tlen, zlen; int bit, bit0; v = z; w = hilf; u = w + modlen + 2; hilf = u + 2*modlen + 2; if(exlen == 0) { z[0] = 1; return(1); } n = modbig(x,n,mm,modlen,hilf); v[0] = 1; vlen = 1; cpyarr(x,n,w); wlen = n; bit = 0; k = ((exlen-1) << 4) + bitlen(ex[exlen-1]); while(--k >= 0) { bit0 = bit; bit = (testbit(ex,k) ? 1 : 0); if(bit != bit0) { temp = v; tlen = vlen; v = w; vlen = wlen; w = temp; wlen = tlen; } /* w := 2*v*w - x */ ulen = multbig(w,wlen,v,vlen,u,hilf); ulen = modbig(u,ulen,mm,modlen,hilf); cpyarr(u,ulen,w); wlen = addarr(w,ulen,u,ulen); if(cmparr(w,wlen,x,n) < 0) wlen = addarr(w,wlen,mm,modlen); wlen = subarr(w,wlen,x,n); /* v := 2*v*v - 1 */ ulen = multbig(v,vlen,v,vlen,u,hilf); ulen = modbig(u,ulen,mm,modlen,hilf); cpyarr(u,ulen,v); vlen = addarr(v,ulen,u,ulen); if(vlen == 0) { cpyarr(mm,modlen,v); vlen = modlen; } vlen = decarr(v,vlen,1); } zlen = (bit == 0 ? vlen : wlen); zlen = modbig(z,zlen,mm,modlen,hilf); return(zlen); } /*------------------------------------------------------------------*/ /* ** mod_pemult(Base,Exponent,Param,Module) */ PRIVATE truc Fpemult(argn) int argn; /* argn = 4 */ { truc *ptr; truc vector, obj; word2 *x, *y, *aa, *z, *res, *hilf; int len, n1, n2, n3, alen; int sign1, sign2, sign; if(chkints(pemultsym,argStkPtr-3,4) == aERROR) return(brkerr()); x = AriScratch; res = AriBuf; hilf = AriScratch + aribufSize; n1 = bigretr(argStkPtr-3,x,&sign1); n2 = bigref(argStkPtr-2,&y,&sign); alen = bigref(argStkPtr-1,&aa,&sign2); n3 = bigref(argStkPtr,&z,&sign); if(!n3) { error(pemultsym,err_div,voidsym); return(brkerr()); } len = pemult(x,n1,y,n2,aa,alen,z,n3,res,hilf); vector = mkvect0(2); WORKpush(vector); if(len >= 0) { obj = mkint(0,res,len); } else { obj = mkint(0,res,-len-1); } ptr = VECTORPTR(workStkPtr); ptr[0] = obj; ptr[1] = (len >= 0 ? constone : zero); vector = WORKretr(); return(vector); } /*------------------------------------------------------------------*/ /* ** Berechnet fuer die elliptische Kurve B*y*y = x*x*x + aa*x*x + x ** in z die x-Koordinate modulo mm von ex*P, ** wobei P ein Punkt der Kurve mit x-Koordinate (x,n) ist. ** Falls die Berechnung scheitert, weil ein Teiler von ** mm auftaucht, wird dieser Teiler in z abgelegt; ** der Rueckgabewert ist dann -(lenz + 1). */ PUBLIC int pemult(x,n,ex,exlen,aa,alen,mm,modlen,z,hilf) word2 *x, *ex, *aa, *mm, *z, *hilf; int n, exlen, alen, modlen; { word2 *yy1, *yy2, *pp1, *pp2, *uu1, *uu2; int zlen, y1len, y2len, p1len, p2len, u1len, u2len; int k, n0, n1, m0, m1; int sign0, sign1; int odd; int ll; int first; struct { word2 *num; word2 *den; int nlen; int dlen; } vv, ww, *act0, *act1; ll = 2*modlen + 2; vv.num = z; vv.den = hilf; ww.num = hilf + ll; ww.den = hilf + 2*ll; yy1 = hilf + 3*ll; yy2 = hilf + 4*ll; pp1 = hilf + 5*ll; pp2 = hilf + 6*ll; uu1 = hilf + 7*ll; uu2 = hilf + 8*ll; hilf = hilf + 9*ll; n = modbig(x,n,mm,modlen,hilf); if(exlen == 0) { cpyarr(mm,modlen,z); return(-modlen); } cpyarr(x,n,vv.num); vv.nlen = n; vv.den[0] = 1; vv.dlen = 1; cpyarr(x,n,ww.num); ww.nlen = n; ww.den[0] = 1; ww.dlen = 1; first = 1; k = ((exlen-1) << 4) + bitlen(ex[exlen-1]); while(--k >= 0) { odd = testbit(ex,k); act0 = (odd ? &ww : &vv); act1 = (odd ? &vv : &ww); n0 = act0->nlen; m0 = act0->dlen; n1 = act1->nlen; m1 = act1->dlen; if(first) { first = 0; goto duplic; } /* ** i --> 2*i + 1 ** X(2*i+1) = ((X(i+1)-Z(i+1))*(X(i)+Z(i)) + (X(i+1)+Z(i+1))*(X(i)-Z(i)))**2 ** Z(2*i+1) = x*(((X(i+1)-Z(i+1))*(X(i)+Z(i))-(X(i+1)+Z(i+1))*(X(i)-Z(i)))**2 */ sign0 = cmparr(act0->num,n0,act0->den,m0); sign1 = cmparr(act1->num,n1,act1->den,m1); cpyarr(act1->num,n1,yy1); if(sign1 >= 0) y1len = subarr(yy1,n1,act1->den,m1); else y1len = sub1arr(yy1,n1,act1->den,m1); cpyarr(act0->num,n0,yy2); y2len = addarr(yy2,n0,act0->den,m0); p1len = multbig(yy1,y1len,yy2,y2len,pp1,hilf); p1len = modbig(pp1,p1len,mm,modlen,hilf); /* pp1 = (X(i+1)-Z(i+1))*(X(i)+Z(i)) */ cpyarr(act1->num,n1,yy1); y1len = addarr(yy1,n1,act1->den,m1); cpyarr(act0->num,n0,yy2); if(sign0 >= 0) y2len = subarr(yy2,n0,act0->den,m0); else y2len = sub1arr(yy2,n0,act0->den,m0); p2len = multbig(yy1,y1len,yy2,y2len,pp2,hilf); p2len = modbig(pp2,p2len,mm,modlen,hilf); /* pp2 = (X(i+1)+Z(i+1))*(X(i)-Z(i)) */ cpyarr(pp1,p1len,uu1); if(sign0 * sign1 >= 0) u1len = addarr(uu1,p1len,pp2,p2len); else if(cmparr(pp1,p1len,pp2,p2len) >= 0) u1len = subarr(uu1,p1len,pp2,p2len); else u1len = sub1arr(uu1,p1len,pp2,p2len); u2len = multbig(uu1,u1len,uu1,u1len,uu2,hilf); u2len = modbig(uu2,u2len,mm,modlen,hilf); cpyarr(uu2,u2len,act1->num); act1->nlen = u2len; cpyarr(pp1,p1len,uu1); if(sign0 * sign1 <= 0) u1len = addarr(uu1,p1len,pp2,p2len); else if(cmparr(pp1,p1len,pp2,p2len) >= 0) u1len = subarr(uu1,p1len,pp2,p2len); else u1len = sub1arr(uu1,p1len,pp2,p2len); u2len = multbig(uu1,u1len,uu1,u1len,uu2,hilf); u2len = modbig(uu2,u2len,mm,modlen,hilf); p1len = multbig(uu2,u2len,x,n,pp1,hilf); p1len = modbig(pp1,p1len,mm,modlen,hilf); cpyarr(pp1,p1len,act1->den); act1->dlen = p1len; duplic: /* ** i --> 2*i ** X(2*i) = (X(i)*X(i) - Z(i)*Z(i))**2 ** Z(2*i) = 4*X(i)*Z(i)*(X(i)*X(i) + A*X(i)*Z(i) + Z(i)*Z(i)) */ y1len = multbig(act0->num,n0,act0->num,n0,yy1,hilf); y1len = modbig(yy1,y1len,mm,modlen,hilf); /* yy1 = X(i)*X(i) */ y2len = multbig(act0->den,m0,act0->den,m0,yy2,hilf); y2len = modbig(yy2,y2len,mm,modlen,hilf); /* yy2 = Z(i)*Z(i) */ u1len = multbig(act0->num,n0,act0->den,m0,uu1,hilf); u1len = modbig(uu1,u1len,mm,modlen,hilf); /* uu1 = X(i)*Z(i) */ u2len = multbig(uu1,u1len,aa,alen,uu2,hilf); u2len = modbig(uu2,u2len,mm,modlen,hilf); /* uu2 = A*X(i)*Z(i) */ cpyarr(yy1,y1len,pp1); if(cmparr(yy1,y1len,yy2,y2len) >= 0) p1len = subarr(pp1,y1len,yy2,y2len); else p1len = sub1arr(pp1,y1len,yy2,y2len); p2len = multbig(pp1,p1len,pp1,p1len,pp2,hilf); p2len = modbig(pp2,p2len,mm,modlen,hilf); cpyarr(pp2,p2len,act0->num); act0->nlen = p2len; cpyarr(yy1,y1len,pp1); p1len = addarr(pp1,y1len,uu2,u2len); p1len = addarr(pp1,p1len,yy2,y2len); p1len = shlarr(pp1,p1len,2); /* pp1 = 4*(X(i)*X(i) + A*X(i)*Z(i) + Z(i)*Z(i)) */ p2len = multbig(pp1,p1len,uu1,u1len,pp2,hilf); p2len = modbig(pp2,p2len,mm,modlen,hilf); cpyarr(pp2,p2len,act0->den); act0->dlen = p2len; } m0 = vv.dlen; cpyarr(vv.den,m0,uu1); m0 = gcdcx(uu1,m0,mm,modlen,pp1,&p1len,hilf); if(m0 != 1 || uu1[0] != 1) { cpyarr(uu1,m0,z); return(-m0-1); } p2len = multbig(vv.num,vv.nlen,pp1,p1len,pp2,hilf); zlen = modbig(pp2,p2len,mm,modlen,hilf); cpyarr(pp2,zlen,z); return(zlen); } /********************************************************************/ aribas165b/src/arity.c0000644000076600000240000024474114660570650013676 0ustar ottostaff/****************************************************************/ /* file arity.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** arity.c ** factorization algorithms (Rho, continued fractions, quadratic sieve) ** and prime generation (next_prime) ** ** date of last change ** 1997-12-09: created by splitting the file aritx.c ** 1997-12-22: qs_factorize, big prime var ** 1998-05-31: fixed bug in function mkquadpol ** 1998-10-11: function next_prime ** 2000-04-26: fixed bug in ATARI version due to ptr diffs > 32K ** 2003-05-30: fixed bug in qs_factorize ** 2004-08-20: removed #define ETEST ** 2007-08-20: fixed bug in ecfactbpv ** 2013-07-04: fixed bug in function factorbase ** 2018-09-13 fixed minor errors and compiler warnings ** (thanks to D. Trebbien for testing) */ #include "common.h" PUBLIC void iniarity (void); PUBLIC void workmess (void); PUBLIC void tick (int c); PUBLIC int showvect (FILE *f, word2 *xx, int len); /*--------------------------------------------------------*/ /********* fuer rho-Faktorisierung **********/ typedef struct { word2 *x, *y, *Q; int xlen, ylen, Qlen; } T_xyQ; #define RHO_CYCLEN 256 #define RHO_INC 2 /********* fuer CF- und QS-Faktorisierung ************/ typedef byte sievitem; typedef struct { word2 *bitmat; word2 *piv; word2 *Aarr; word2 *Qarr; word2 *fbas; int rank; int matinc; int vlen; int ainc; int qinc; int baslen; } BMDATA; #ifdef M_LARGE #define ALEN 20 /* even! */ #define MAXMROWS 3200 /* was 2560 */ #define MAXSRANGE 160000 /* was 128000 */ #define MINSRANGE 6000 #define MEMCHUNK 64000 #define BIGPRIMES #else #define ALEN 12 /* even! */ #define MAXMROWS 512 #define MEMCHUNK 32000 /* < 2**15 */ #define STACKRES 4092 #endif #define HLEN (ALEN/2) typedef struct { word2 kNlen; word2 kN[ALEN+1]; word2 m2[HLEN+1]; word2 R0[HLEN+1]; word2 Q0[HLEN+1]; word2 A0[ALEN+1]; word2 QQ[HLEN+1]; word2 AA[ALEN]; int qrsign; } CFDATA; typedef struct { word2 NNlen; word2 NN[ALEN+1]; word2 qq[HLEN+1]; word2 qinv[ALEN+1]; word2 aa[HLEN+1]; word2 bb[HLEN+1]; word2 cc[ALEN]; int xi; } QPOLY; typedef struct { word2 *fbas; word2 *fbroot; sievitem *fblog; int baslen; } QSFBAS; #ifdef BIGPRIMES /* for big prime variation in quadratic sieve factorization */ #define BPMINLEN 8 /* minimal length for using big prime var */ #define BPMAXIDX 5 PRIVATE unsigned QShtablen[BPMAXIDX] = {16000, 24000, 40000, 64000, 96000}; PRIVATE unsigned QShconst[BPMAXIDX] = {31991, 47981, 79967, 127997,191999}; /* primes < 2*QShtablen[k] */ PRIVATE unsigned QSbpblen[BPMAXIDX] = {8,9,10,12,14}; PRIVATE unsigned QSbpbmult[BPMAXIDX] = {1,2,3,4,6}; // PRIVATE unsigned QSbpbmult[BPMAXIDX] = {1,2,3,5,8}; #define BIGPRIMEBOUND0 2000000 typedef struct { word4 bprime; word4 qdiff; int x; } QSBP; typedef struct { word2 q0len; word2 Q0[HLEN]; word2 *hashtab; unsigned tablen; QSBP *QSBPdata; unsigned row; unsigned maxrows; word4 bpbound; } QSBIGPRIMES; typedef struct { sievitem *Sieve; int srange; int useBigprim; QPOLY *qpol; QSFBAS *fbp; QSBIGPRIMES *qsbig; } SIEVEDATA; #else /* !BIGPRIMES */ typedef struct { sievitem *Sieve; int srange; QPOLY *qpol; QSFBAS *fbp; } SIEVEDATA; #endif /*----------------------------------------------------*/ #ifdef BIGPRIMES #define ECMAXIDX 6 #define MAXDIFF 154 PRIVATE unsigned ECbpbound[ECMAXIDX] = {15000, 19500, 31000, 150000, 1300000, 0x1000000}; PRIVATE int ECmdiff[ECMAXIDX] = {36, 44, 52, 72, 114, MAXDIFF}; #endif /*----------------------------------------------------*/ /* elliptic curve c*y**2 = x**3 + a*x**2 + x mod N */ typedef struct { word2 *N; int nlen; word2 *aa; int alen; word2 *cc; int clen; } ECN; /*----------------------------------------------------*/ /* ** Points on elliptic curve are given by structure EPOINT ** Special points: ** Origin: xlen = -1; ** Partial origin: xlen = -2; (yy,ylen) a divisor of N */ typedef struct { word2 *xx; int xlen; word2 *yy; int ylen; } EPOINT; /*-------------------------------------------------------------------*/ /*-------------------------------------------------------------------*/ /* setbit and testbit suppose that vv is an array of word2 */ #define setbit(vv,i) vv[(i)>>4] |= (1 << ((i)&0xF)) #define testbit(vv,i) (vv[(i)>>4] & (1 << ((i)&0xF))) /*-------------------------------------------------------------------*/ PRIVATE truc Frhofact (int argn); PRIVATE int rhocycle (int anz, T_xyQ *xyQ, word2 *N, int len, word2 *hilf); PRIVATE void rhomess (word4 i); PRIVATE unsigned banalfact (word2 *N, int len); #ifdef CFFACT PRIVATE truc Fcffact (int argn); PRIVATE int brillmorr (word2 *N, int len, unsigned v, word2 *fact); PRIVATE int brill1 (word2 *N, int len, unsigned u, word2 *fact, BMDATA *bmp, CFDATA *cfp, word2 *hilf); PRIVATE int cfracinit (word2 *N, int len, unsigned u, CFDATA *cfp, word2 *hilf); PRIVATE int cfracnext (word2 *N, int len, CFDATA *cfp, word2 *hilf); PRIVATE int smoothea (word2 *QQ, word2 *fbas, int baslen, int easize); #endif PRIVATE int bm_alloc (word2 *buf1, size_t len1, word2 *buf2, size_t len2, BMDATA *bmp, int alen, int qlen); PRIVATE unsigned factorbase (word2 *N, int len, word2 *prim, int anz, unsigned *pdivis); PRIVATE word4 smooth (word2 *QQ, word2 *fbas, int baslen); PRIVATE int bm_insert (BMDATA *bmp, word2 *QQ, int qsign, word2 *AA, word2 *hilf); PRIVATE int gausselim (BMDATA *bmp); PRIVATE int getfactor (word2 *N, int len, BMDATA *bmp, word2 *fact, word2 *hilf); PRIVATE truc Fqsfact (int argn); PRIVATE int mpqsfactor (word2 *N, int len, word2 *fact); PRIVATE int qsfact1 (word2 *N, int len, word2 *fact, BMDATA *bmp, SIEVEDATA *qsp, word2 *hilf); PRIVATE int ppexpo (unsigned B1, unsigned B2, word2 *xx); PRIVATE int startqq (word2 *N, int len, unsigned srange, word2 *qq, word2 *hilf); PRIVATE int nextqq (word2 *N, int len, word2 *q0, int q0len, word2 *qq, word2 *hilf); PRIVATE int dosieve (SIEVEDATA *qsp); PRIVATE int mkquadpol (word2 *p, int plen, QPOLY *sptr, word2 *hilf); PRIVATE int quadvalue (QPOLY *polp, word2 *QQ, int *signp); PRIVATE int qresitem (QPOLY *polp, word2 *AA); PRIVATE void counttick0 (unsigned v); PRIVATE void counttick (word4 v, BMDATA *bmp); #ifdef CFFACT PRIVATE void cf0mess (int p, int blen); PRIVATE void cf1mess (long n, int nf); #endif PRIVATE void qs0mess (int srange, int p, int blen); PRIVATE void qs1mess (long n, int nf); PRIVATE void ec0mess (unsigned bound); PRIVATE void ec1mess (unsigned bound1, unsigned bound2); PRIVATE void ec2mess (unsigned param, unsigned bound1); PRIVATE void ec3mess (unsigned param, unsigned bigbound); PRIVATE int is_square (word2 *N, int len, word2 *root, word2 *hilf); PRIVATE int multlarr (word2 *x, int n, unsigned a, word2 *y); #if 0 PRIVATE int p2sqrt (word2 *p, int plen, word2 *x, int xlen, word2 *z, word2 *hilf); #endif #ifdef BIGPRIMES PRIVATE int hashbigp (QSBIGPRIMES *qsbigp, word4 prim, QPOLY *qpolp, QPOLY *qpolp2, word2 *hilf); PRIVATE int combinebp (word2 *N, int len, word4 prim, word2 *QQ, word2 *AA, word2 *QQ2, word2 *AA2, word2 *hilf); PRIVATE void qs2mess (long n, int nf, int nf2); #endif PRIVATE truc Fecfactor (int argn); PRIVATE int ecfacta (word2 *N, int len, word2 *aa, int alen, word2 *xx, int xlen, unsigned *pbound, word2 *hilf); PRIVATE int ecbpvalloc (EPOINT *pEpoint, word2 *buf, size_t buflen, int nlen, unsigned *pbound); PRIVATE int ecfactbpv (ECN *pecN, EPOINT *pEpoint, unsigned *pbound, int hdiff, word2 *xx, int xlen, word2 *hilf); PRIVATE int ECNx2c (ECN *pecN, word2 *xx, int xlen, word2 *hilf); PRIVATE int ECNadd (ECN *pecN, EPOINT *pZ1, EPOINT *pZ2, word2 *hilf); PRIVATE int ECNdup (ECN *pecN, EPOINT *pZ, word2 *hilf); #ifdef CFFACT PRIVATE truc cffactsym; #endif PRIVATE truc rhosym, qsfactsym; PRIVATE truc ecfactsym; #ifdef ETEST PRIVATE truc eeesym, ee1sym, ee2sym; PRIVATE truc Feee (void); PRIVATE truc Fee1 (void); PRIVATE truc Fee2 (void); PRIVATE int ECNmult (ECN *pecN, EPOINT *pZ, word2 *ex, int exlen, word2 *hilf); #endif /* #define QTEST */ #ifdef QTEST PRIVATE FILE *dbgf; #endif PRIVATE int doreport; /*------------------------------------------------------------------*/ PUBLIC void iniarity() { rhosym = newsymsig("rho_factorize",sFBINARY,(wtruc)Frhofact, s_13); #ifdef CFFACT cffactsym = newsymsig("cf_factorize", sFBINARY,(wtruc)Fcffact, s_13); #endif qsfactsym = newsymsig("qs_factorize", sFBINARY,(wtruc)Fqsfact, s_12); ecfactsym = newsymsig("ec_factorize", sFBINARY, (wtruc)Fecfactor,s_14); #ifdef ETEST eeesym = newsymsig("eee", sFBINARY, (wtruc)Feee, s_3); ee1sym = newsymsig("ee1", sFBINARY, (wtruc)Fee1, s_3); ee2sym = newsymsig("ee2", sFBINARY, (wtruc)Fee2, s_4); #endif } /*-------------------------------------------------------------------*/ #if 0 #ifdef E2TEST /* only for testing */ FILE *elog; #endif #ifdef E2TEST elog = fopen("e2test.log","w"); fprintf(elog,"N := "); showvect(elog,N,len); #endif #ifdef E2TEST fclose(elog); #endif #endif /*-------------------------------------------------------------------*/ PUBLIC int showvect(logf,vect,len) FILE *logf; word2 *vect; int len; { int i; fprintf(logf,"0x"); for(i=len-1; i>=0; i--) fprintf(logf,"%04X",vect[i]); fprintf(logf,"\n"); return len; } /*-------------------------------------------------------------------*/ #ifdef ETEST PRIVATE truc Feee() { word2 *N, *aa, *xx; int alen, clen, xlen, sign, nlen; ECN ecN; if(chkints(eeesym,argStkPtr-2,3) == aERROR) return(brkerr()); nlen = bigref(argStkPtr-2,&N,&sign); alen = bigref(argStkPtr-1,&aa,&sign); xlen = bigref(argStkPtr,&xx,&sign); ecN.cc = AriBuf; ecN.aa = aa; ecN.alen = alen; ecN.N = N; ecN.nlen = nlen; clen = ECNx2c(&ecN,xx,xlen,AriScratch); if(clen >= 0) return mkint(0,AriBuf,clen); else return zero; } /*-------------------------------------------------------------------*/ PRIVATE truc Fee1() { word2 *N, *aa, *xx, *yy, *cc, *ex, *hilf; int len, alen, clen, xlen, exlen, sign, nlen; ECN ecN; EPOINT PP; if(chkints(eeesym,argStkPtr-2,3) == aERROR) return(brkerr()); nlen = bigref(argStkPtr-2,&N,&sign); alen = bigref(argStkPtr-1,&aa,&sign); xlen = bigref(argStkPtr,&xx,&sign); cc = AriScratch; hilf = cc + 2*nlen + 2; ecN.cc = cc; ecN.aa = aa; ecN.alen = alen; ecN.N = N; ecN.nlen = nlen; clen = ECNx2c(&ecN,xx,xlen,hilf); if(clen < 0) return brkerr(); cpyarr(xx,xlen,AriBuf); xx = AriBuf; yy = AriBuf + nlen + xlen; PP.xx = xx; PP.xlen = xlen; PP.yy = yy; yy[0] = 1; PP.ylen = 1; len = ECNdup(&ecN,&PP,hilf); if(len > 0) return mkint(0,AriBuf,len); else return mkinum(len); } /*-------------------------------------------------------------------*/ PRIVATE truc Fee2() { word2 *N, *aa, *xx, *yy, *cc, *ex, *hilf; int len, alen, clen, xlen, exlen, sign, nlen; ECN ecN; EPOINT PP; if(chkints(eeesym,argStkPtr-3,4) == aERROR) return(brkerr()); nlen = bigref(argStkPtr-3,&N,&sign); alen = bigref(argStkPtr-2,&aa,&sign); xlen = bigref(argStkPtr-1,&xx,&sign); exlen = bigref(argStkPtr,&ex,&sign); cc = AriScratch; hilf = cc + 2*nlen + 2; ecN.cc = cc; ecN.aa = aa; ecN.alen = alen; ecN.N = N; ecN.nlen = nlen; clen = ECNx2c(&ecN,xx,xlen,hilf); if(clen < 0) return brkerr(); cpyarr(xx,xlen,AriBuf); xx = AriBuf; if(xlen > nlen) xlen = modbig(xx,xlen,N,nlen,hilf); yy = AriBuf + 2*nlen; PP.xx = xx; PP.xlen = xlen; PP.yy = yy; yy[0] = 1; PP.ylen = 1; len = ECNmult(&ecN,&PP,ex,exlen,hilf); if(len > 0) return mkint(0,AriBuf,len); else return mkinum(len); } #endif /* ETEST */ /*-------------------------------------------------------------------*/ /* ** Messages for factorization algorithms */ PUBLIC void workmess() { fnewline(tstdout); fprintstr(tstdout,"working "); } /*-------------------------------------------------------------------*/ PUBLIC void tick(c) int c; { char tt[2]; tt[0] = c; tt[1] = 0; fprintstr(tstdout,tt); } /*-------------------------------------------------------------------*/ PRIVATE void counttick0(v) unsigned v; { char messbuf[80]; s1form(messbuf,"~D",intcast(v)); fprintstr(tstdout,messbuf); } /*-------------------------------------------------------------------*/ PRIVATE void counttick(v,bmp) word4 v; BMDATA *bmp; { char messbuf[80]; word4 z,w; int c; if(v&0x7F) { tick('_'); } else { v >>= 7; c = v % 10; if(c) { tick('0' + c); } else { z = v/10; w = bmp->rank; w *= 100; w /= bmp->baslen; s2form(messbuf,"[~D/~D%]",intcast(z),intcast(w)); fprintstr(tstdout,messbuf); } } } /*-------------------------------------------------------------------*/ PRIVATE void rhomess(anz) word4 anz; { char messbuf[80]; s1form(messbuf,"~%factor found after ~D iterations",intcast(anz)); fprintline(tstdout,messbuf); fnewline(tstdout); } /*-------------------------------------------------------------------*/ #ifdef CFFACT PRIVATE void cf0mess(p,blen) int p, blen; { char messbuf[80]; s2form(messbuf,"~%CF-algorithm: factorbase 2 ... ~D of length ~D", intcast(p),intcast(blen)); fprintline(tstdout,messbuf); fprintstr(tstdout,"working "); } /*-------------------------------------------------------------------*/ PRIVATE void cf1mess(n,nf) long n; int nf; { char messbuf[80]; s2form(messbuf, "~%~D quadratic residues calculated, ~D completely factorized", intcast(n),intcast(nf)); fprintline(tstdout,messbuf); fnewline(tstdout); } #endif /*-------------------------------------------------------------------*/ PRIVATE void qs0mess(srange,p,blen) int srange, p, blen; { char messbuf[80]; s1form(messbuf,"~%quadratic sieve length = ~D, ",intcast(2*srange)); fprintstr(tstdout,messbuf); s2form(messbuf,"factorbase 2 ... ~D of length ~D", intcast(p),intcast(blen)); fprintline(tstdout,messbuf); fprintstr(tstdout,"working "); } /*-------------------------------------------------------------------*/ PRIVATE void qs1mess(n,nf) long n; int nf; { char messbuf[80]; s2form(messbuf, "~%~D polynomials, ~D completely factorized quadratic residues", intcast(n),intcast(nf)); fprintline(tstdout,messbuf); fnewline(tstdout); } /*------------------------------------------------------------------*/ #ifdef BIGPRIMES /*------------------------------------------------------------------*/ PRIVATE void qs2mess(n,nf,nf2) long n; int nf, nf2; { char messbuf[80]; s2form(messbuf,"~%~D polynomials, ~D + ",intcast(n),intcast(nf-nf2)); fprintstr(tstdout,messbuf); s2form(messbuf,"~D = ~D factorized quadratic residues", intcast(nf2),intcast(nf)); fprintline(tstdout,messbuf); fnewline(tstdout); } /*------------------------------------------------------------------*/ #endif /*------------------------------------------------------------------*/ PRIVATE void ec0mess(bound) unsigned bound; { char messbuf[80]; s1form(messbuf,"~%EC factorization with prime bound ~D ~%working ", intcast(bound)); fprintstr(tstdout,messbuf); } /*------------------------------------------------------------------*/ PRIVATE void ec1mess(bound1, bound2) unsigned bound1, bound2; { char messbuf[80]; s2form(messbuf, "~%EC factorization, prime bound ~D, bigprime bound ~D~%working ", intcast(bound1), intcast(bound2)); fprintstr(tstdout,messbuf); } /*------------------------------------------------------------------*/ PRIVATE void ec2mess(u,bound1) unsigned u,bound1; { char messbuf[80]; s2form(messbuf, "~%factor found with curve parameter ~D and prime bound ~D~%", intcast(u),intcast(bound1)); fprintline(tstdout,messbuf); } /*------------------------------------------------------------------*/ PRIVATE void ec3mess(u,bound2) unsigned u,bound2; { char messbuf[80]; s2form(messbuf, "~%factor found with curve parameter ~D and bigprime ~D~%", intcast(u),intcast(bound2)); fprintline(tstdout,messbuf); } /*------------------------------------------------------------------*/ /* ** Pollardsche rho-Methode zur Faktorisierung; ** Aufruf rho_factorize(N,anz) oder rho_factorize(N); ** dabei ist anz die maximale Anzahl der Iterationen, ** default anz = 2**16 */ PRIVATE truc Frhofact(argn) int argn; { T_xyQ xyQ; truc *argptr; word2 *N, *z, *d, *Q, *hilf; word4 u, i; size_t m; unsigned rr; int k, n, len, sign, ret; argptr = argStkPtr-argn+1; if(argn >= 2 && *argStkPtr == zero) { doreport = 0; argn--; } else { doreport = 1; } if(chkints(rhosym,argptr,argn) == aERROR) return(brkerr()); len = bigref(argptr,&N,&sign); m = aribufSize/4; if(len >= (m-1)/2) { error(rhosym,err_ovfl,*argptr); return(brkerr()); } d = AriBuf; xyQ.x = d + m; xyQ.y = d + 2*m; xyQ.Q = d + 3*m; Q = AriScratch; hilf = AriScratch + aribufSize; rr = random2(64000); xyQ.x[0] = xyQ.y[0] = rr; xyQ.xlen = xyQ.ylen = (rr ? 1 : 0); xyQ.Q[0] = 1; xyQ.Qlen = 1; if(argn == 2) { n = bigref(argptr+1,&z,&sign); if(n <= 2 && n) u = big2long(z,n); else u = 0x80000000; } else u = 0x10000; if(doreport) workmess(); for(i=0; i 1 || *d > 1) { if(doreport) rhomess(i+RHO_CYCLEN); return(mkint(0,d,k)); } } if(INTERRUPT) { setinterrupt(0); break; } } return(zero); } /*-------------------------------------------------------------------*/ /* ** Berechnet anz mal ** x -> x*x+RHO_INC; x -> x*x+RHO_INC; y -> y*y+RHO_INC mod N ** Q -> Q*(x-y) mod N ** Rueckgabewert Laenge von Q */ PRIVATE int rhocycle(anz,xyQ,N,len,hilf) int anz; T_xyQ *xyQ; word2 *N; int len; word2 *hilf; { word2 *x1, *y1, *Q1, *z, *z1; int n, m, k, cmp; int zlen, z1len, nn; nn = 2*len + 2; z = hilf; z1 = hilf + nn; hilf = z1 + nn; x1 = xyQ->x; n = xyQ->xlen; y1 = xyQ->y; m = xyQ->ylen; Q1 = xyQ->Q; *Q1 = 1; k = 1; while(--anz >= 0) { zlen = multbig(x1,n,x1,n,z,hilf); zlen = incarr(z,zlen,RHO_INC); zlen = modbig(z,zlen,N,len,hilf); z1len = multbig(z,zlen,z,zlen,z1,hilf); z1len = incarr(z1,z1len,RHO_INC); n = modbig(z1,z1len,N,len,hilf); cpyarr(z1,n,x1); zlen = multbig(y1,m,y1,m,z,hilf); zlen = incarr(z,zlen,RHO_INC); m = modbig(z,zlen,N,len,hilf); cpyarr(z,m,y1); cmp = cmparr(z,m,z1,n); if(cmp > 0) zlen = subarr(z,m,z1,n); else if(cmp < 0) zlen = sub1arr(z,m,z1,n); else continue; z1len = multbig(Q1,k,z,zlen,z1,hilf); k = modbig(z1,z1len,N,len,hilf); cpyarr(z1,k,Q1); } xyQ->xlen = n; xyQ->ylen = m; xyQ->Qlen = k; return(k); } /*------------------------------------------------------------------*/ #ifdef CFFACT /* ** Continued fraction factorization ** cf_factorize(N: integer[; mult: integer]): integer; */ PRIVATE truc Fcffact(argn) int argn; { truc *argptr; word2 *N, *x; long mm; size_t buflen; unsigned u; int len0, len, n; int sign; argptr = argStkPtr-argn+1; if(argn >= 2 && *argStkPtr == zero) { doreport = 0; argn--; } else { doreport = 1; } if(chkints(cffactsym,argptr,argn) == aERROR) return(brkerr()); len = bigref(argptr,&N,&sign); u = banalfact(N,len); if(u != (unsigned)-1) return(mkfixnum(u)); buflen = auxbufSize * sizeof(word2); #ifdef M_SMALL mm = stkcheck() - STACKRES; if(buflen < mm) mm = buflen; #else mm = buflen; #endif len0 = ALEN; if(mm < MEMCHUNK) { error(cffactsym,err_memev,voidsym); return(brkerr()); } if(len > len0 || (len == len0 && bitlen(N[len-1]) > 4)) { error(cffactsym,err_2big,*argptr); return(brkerr()); } if(argn >= 2) { n = bigref(argptr+1,&x,&sign); u = *x; if(n != 1 || u > 1023) u = 1; } else u = 1; n = brillmorr(N,len,u,AriBuf); return(mkint(0,AriBuf,n)); } #endif /*------------------------------------------------------------------*/ /* ** Falls (N,len) < 2**32 wird der kleinste Primfaktor zurueckgegeben. ** Falls N gerade, wird 2 zurueckgegeben. ** Falls N durch 3,5,7,11 teilbar, wird kleiner Faktor zurueckgegeben ** Andernfalls wird (unsigned)-1 zurueckgegeben. */ PRIVATE unsigned banalfact(N,len) word2 *N; int len; { word4 u; unsigned v,d; if(len <= 2) { u = big2long(N,len); v = intsqrt(u); d = trialdiv(N,len,2,v); return(d); } else if(!(N[0] & 1)) return(2); /* else */ v = 15015; /* 3*5*7*11*13 */ d = modarr(N,len,v); d = shortgcd(d,v); if(d > 1) return d; else return((unsigned)-1); } /*------------------------------------------------------------------*/ #ifdef CFFACT PRIVATE int brillmorr(N,len,v,fact) word2 *N, *fact; int len; unsigned v; { #ifdef M_SMALL word2 stackpiece[MEMCHUNK/sizeof(word2)]; #endif BMDATA bm; CFDATA cf; word2 *buf1, *buf2, *hilf; word4 u; size_t b1len, b2len; int k, alen, qlen, baslen, maxrows, b0, b1, b, ret; b1 = bitlen(N[len-1]); alen = (b1 > 4 ? len+1 : len); qlen = (alen + 1)/2; #ifdef M_SMALL buf1 = AriScratch; b1len = scrbufSize; /* scrbufSize >= auxbufSize in M_SMALL */ buf2 = stackpiece; b2len = MEMCHUNK/sizeof(word2); hilf = AuxBuf; #else buf1 = AuxBuf; b1len = auxbufSize/2; buf2 = AuxBuf + b1len; b2len = b1len; hilf = AriScratch; #endif maxrows = bm_alloc(buf1,b1len,buf2,b2len,&bm,alen,qlen); b0 = maxrows/16; u = (len - 1)*16 + b1; /* bitlength of N */ b = 1 + (u*u)/384; if(b > b0) b = b0; bm.vlen = b; bm.baslen = baslen = b * 16 - 2; for(k=0; k<=baslen; k++) bm.piv[k] = baslen-k; /* bm.piv[k] = k; */ bm.fbas = hilf; hilf += b * 16; ret = brill1(N,len,v,fact,&bm,&cf,hilf); return(ret); } #endif /*-------------------------------------------------------------------*/ /* ** In (buf1,len1) und (buf2,len2) werden zwei Puffer uebergeben ** Aus diesen wird der Struktur *bmp Speicher zugewiesen ** ** Bedarf fuer bmp: ** bmp->bitmat Platz fuer eine Bitmatrix maxrows*(2*maxrows) ** bmp->piv Platz fuer maxrows word2's ** bmp->fbas Platz fuer maxrows word2's ** bmp->Aarr Platz fuer maxrows bigints der Laenge alen, ** zuzueglich Laengen-Angabe ** bmp->Qarr Platz fuer maxrows bigints der Laenge qlen, ** zuzueglich Laengen-Angabe ** ** Rueckgabewert ist maxrows; dies ist durch 16 teilbar */ PRIVATE int bm_alloc(buf1,len1,buf2,len2,bmp,alen,qlen) word2 *buf1, *buf2; size_t len1, len2; BMDATA *bmp; int alen, qlen; { word2 *xx, *yy; word4 u; size_t ll; int maxrows; /* allocation for bmp->bitmat (from buf1) */ u = len1; u *= 8; maxrows = (int)intsqrt(u); if(maxrows > MAXMROWS) maxrows = MAXMROWS; maxrows &= 0x7FF0; /* make it a multiple of 16 */ bmp->bitmat = buf1; bmp->matinc = maxrows/8; bmp->rank = 0; /* allocation for Aarr, Qarr, piv (from buf2) */ alen++; qlen++; /* one word2 for length specification */ ll = len2 / (alen + qlen + 1); if(ll < maxrows) { maxrows = (ll & 0x7FF0); } bmp->Aarr = buf2 + 1; bmp->ainc = alen; xx = buf2 + alen * maxrows; bmp->Qarr = xx + 1; bmp->qinc = qlen; yy = xx + qlen * maxrows; bmp->piv = yy; return(maxrows); } /*-------------------------------------------------------------------*/ #ifdef CFFACT PRIVATE int brill1(N,len,u,fact,bmp,cfp,hilf) word2 *N, *fact, *hilf; unsigned u; int len; BMDATA *bmp; CFDATA *cfp; { word2 *zz, *fbase; word4 v; int k, qrlen, baslen, easize, res; int count, count1, maxshrieks; unsigned divis; qrlen = cfracinit(N,len,u,cfp,hilf); if(qrlen == 0) { k = cfp->AA[-1]; cpyarr(cfp->AA,k,fact); zz = cfp->kN; cpyarr(N,len,zz); return(biggcd(fact,k,zz,len,hilf)); } fbase = bmp->fbas; baslen = factorbase(cfp->kN,(int)cfp->kN[-1],fbase,bmp->baslen,&divis); bmp->baslen = baslen; if(doreport) cf0mess(fbase[baslen-1],baslen); easize = intsqrt(6*(word4)baslen); /* ?! */ maxshrieks = (baslen < 100 ? 20 : 20 + (baslen/2 - 50)/bitlen(baslen)); for(v=1, count=count1=0; qrlen && count1>10,bmp); } } if(smoothea(cfp->QQ,fbase,baslen,easize)) { if((++count & 0x3) == 1) if(doreport) tick('.'); res = bm_insert(bmp,cfp->QQ,cfp->qrsign,cfp->AA,hilf); if(res && gausselim(bmp)) { count1++; if(doreport) tick('!'); k = getfactor(N,len,bmp,fact,hilf); if(k > 0) { if(doreport) cf1mess(v,count); return(k); } } } qrlen = cfracnext(N,len,cfp,hilf); } return(0); } #endif /*------------------------------------------------------------------*/ /* ** Schreibt in das Array fbase die Primzahl 2 und weitere (anz-1) ** ungerade 16-bit-Primzahlen, fuer die jacobi((N,len),p) = 1 ** Falls N durch eine Primzahl, die kleiner als das Maximum ** der Faktorbasis ist, teilbar ist, wird diese zurueckgegeben, ** andernfalls 0. */ PRIVATE unsigned factorbase(N,len,fbase,anz,pdivis) word2 *N, *fbase; int len, anz; unsigned *pdivis; { unsigned m, p; unsigned divisor = 0; int idx; fbase[0] = 2; for(idx=1, p=3; idx 0xFFF1) { /* 0xFFF1 = 65521 largest 16-bit prime */ anz = idx; break; } if(!prime16(p)) continue; m = modarr(N,len,p); if(m == 0 && divisor == 0) { divisor = p; } if(jac(m,p) >= 0) { fbase[idx] = p; idx++; } } *pdivis = divisor; return(anz); } /*-------------------------------------------------------------------*/ #ifdef CFFACT PRIVATE int cfracinit(N,len,u,cfp,hilf) word2 *N; int len; unsigned u; CFDATA *cfp; word2 *hilf; { word2 *temp, *temp1; int k, n, rlen; int ll = 2*len + 2; temp = hilf; temp1 = temp + ll; hilf = temp1 + ll; len = multarr(N,len,u,temp); cpyarr(temp,len,cfp->kN); cfp->kN[-1] = len; k = bigsqrt(temp,len,temp1,&rlen,hilf); cpyarr(temp1,k,cfp->AA); cfp->AA[-1] = k; n = multbig(temp1,k,temp1,k,temp,hilf); rlen = sub1arr(temp,n,cfp->kN,len); cpyarr(temp,rlen,cfp->QQ); cfp->QQ[-1] = rlen; k = shlarr(temp1,k,1); cpyarr(temp1,k,cfp->m2); cfp->m2[-1] = k; cfp->R0[-1] = 0; cfp->A0[0] = 1; cfp->A0[-1] = 1; cfp->Q0[0] = 1; cfp->Q0[-1] = 1; cfp->qrsign = -1; return(rlen); } /*-------------------------------------------------------------------*/ /* ** m2 - R0 = bb * QQ + rest; ** Qnew = Q0 + (rest - R0) * bb; ** Anew = (AA * bb + A0) mod N ** next R0 = rest ** next Q0 = QQ ** next A0 = AA ** next QQ = Qnew ** next AA = Anew */ PRIVATE int cfracnext(N,len,cfp,hilf) word2 *N; int len; CFDATA *cfp; word2 *hilf; { static word2 rr[HLEN], bb[HLEN], temp1[HLEN]; word2 *QQ, *Qtemp, *Atemp; int m2len, rlen, blen, qtlen, atlen, t1len; int cmp; Qtemp = Atemp = hilf; hilf += 2*ALEN; QQ = cfp->QQ; m2len = cfp->m2[-1]; cpyarr(cfp->m2,m2len,rr); m2len = subarr(rr,m2len,cfp->R0,(int)cfp->R0[-1]); blen = divbig(rr,m2len,QQ,(int)QQ[-1],bb,&rlen,hilf); cpyarr(rr,rlen,temp1); t1len = rlen; cmp = cmparr(temp1,t1len,cfp->R0,(int)cfp->R0[-1]); if(cmp >= 0) t1len = subarr(temp1,t1len,cfp->R0,(int)cfp->R0[-1]); else t1len = sub1arr(temp1,t1len,cfp->R0,(int)cfp->R0[-1]); cpyarr(rr,rlen,cfp->R0); cfp->R0[-1] = rlen; qtlen = multbig(temp1,t1len,bb,blen,Qtemp,hilf); if(cmp >= 0) qtlen = addarr(Qtemp,qtlen,cfp->Q0,(int)cfp->Q0[-1]); else qtlen = sub1arr(Qtemp,qtlen,cfp->Q0,(int)cfp->Q0[-1]); cpyarr(QQ,(int)QQ[-1],cfp->Q0); cfp->Q0[-1] = QQ[-1]; cpyarr(Qtemp,qtlen,QQ); QQ[-1] = qtlen; atlen = multbig(cfp->AA,(int)cfp->AA[-1],bb,blen,Atemp,hilf); atlen = addarr(Atemp,atlen,cfp->A0,(int)cfp->A0[-1]); atlen = modbig(Atemp,atlen,N,len,hilf); cpyarr(cfp->AA,(int)cfp->AA[-1],cfp->A0); cfp->A0[-1] = cfp->AA[-1]; cpyarr(Atemp,atlen,cfp->AA); cfp->AA[-1] = atlen; cfp->qrsign = -cfp->qrsign; return(qtlen); } /*-------------------------------------------------------------------*/ /* ** Rueckgabe = 1, falls quadratischer Rest QQ smooth; sonst = 0 ** QQ[-1] enthaelt Laengenangabe ** TODO: big prime variation */ PRIVATE int smoothea(QQ,fbas,baslen,easize) word2 *QQ, *fbas; int baslen, easize; { word2 Q[ALEN]; unsigned p; int qn, i, bitl, bound; word2 r; qn = QQ[-1]; cpyarr(QQ,qn,Q); bitl = (qn - 1)*16 + bitlen(Q[qn-1]); bound = easize; i = 0; nochmal: while(++i <= bound) { p = *fbas++; while(modarr(Q,qn,p) == 0) qn = divarr(Q,qn,p,&r); if(qn == 1 && Q[0] == 1) return(1); } if(bound < baslen) { if(bitl - 16*(qn - 1) - bitlen(Q[qn-1]) >= 10) { bound = baslen; goto nochmal; } /* else early abort */ } return(0); } #endif /*-------------------------------------------------------------------*/ /* ** QQ[-1] contains length of QQ, which must be <= ALEN ** Extracts from QQ all prime factors in fbas ** returns last cofactor u if u < 2**32; ** else returns 0 */ PRIVATE word4 smooth(QQ,fbas,baslen) word2 *QQ, *fbas; int baslen; { word2 Q[ALEN]; unsigned p; int qn, i; word2 r; qn = QQ[-1]; if(!qn) return 0; cpyarr(QQ,qn,Q); for(i=0; irank; Q = bmp->Qarr + bmrk*(bmp->qinc); qn = Q[-1] = QQ[-1]; cpyarr(QQ,qn,Q); cpyarr(QQ,qn,aux); A = bmp->Aarr + bmrk*(bmp->ainc); alen = AA[-1]; A[-1] = alen; cpyarr(AA,(int)A[-1],A); vect = bmp->bitmat + bmrk*(bmp->matinc); setarr(vect,bmp->vlen,0); if(qsign) vect[0] = 1; /* setbit(vect,0); */ prime = bmp->fbas; baslen = bmp->baslen; i = 0; while(++i<=baslen) { p = *prime++; v = 0; while(modarr(aux,qn,p) == 0) { v++; qn = divarr(aux,qn,p,&r); } if(v & 1) setbit(vect,i); if((qn == 1) && (aux[0] == 1)) { return(1); } } return(0); } /*-------------------------------------------------------------------*/ /* ** Rueckgabe = 0, falls letzte Zeile unabhaengig; sonst = 1 */ PRIVATE int gausselim(bmp) BMDATA *bmp; { word2 *v, *vect, *vectb, *piv; unsigned pivot, minc; int i; int vn, v2n, baslen; size_t rk; minc = bmp->matinc; rk = bmp->rank; vn = bmp->vlen; v2n = 2*vn; baslen = bmp->baslen; vect = bmp->bitmat + rk * minc; vectb = vect + vn; setarr(vectb,vn,0); setbit(vectb,rk); v = bmp->bitmat; piv = bmp->piv; for(i=0; irank = rk + 1; return(0); } /*-------------------------------------------------------------------*/ /* ** Tries to find a factor of N ** Hypothesis: The current row of the bit matrix in *bmp ** is linearly dependent from the previous rows. ** fact is a word2 array large enough to hold the factor ** If a factor is found, the number of linear dependent rows ** which contributed to finding the factor is stored in hilf[0]. */ PRIVATE int getfactor(N,len,bmp,fact,hilf) word2 *N, *fact, *hilf; int len; BMDATA *bmp; { word2 *relat, *temp, *aux, *A, *AA, *Q, *QQ, *XX, *X1, *X2; int cmp, k; size_t rk, ainc, qinc; int count; int alen, qlen, q1len, tlen, xlen, x1len, x2len; int ll, lll; ll = 2*ALEN + 2; lll = 4*ALEN; A = hilf; XX = A + ll; X1 = XX + ll; X2 = X1 + ll; Q = X2 + ll; temp = Q + lll; aux = temp + lll; rk = bmp->rank; relat = bmp->bitmat + rk * (bmp->matinc) + (bmp->vlen); ainc = bmp->ainc; qinc = bmp->qinc; AA = bmp->Aarr + rk*ainc; alen = AA[-1]; cpyarr(AA,alen,A); AA = bmp->Aarr; XX[0] = 1; xlen = 1; QQ = bmp->Qarr + rk*qinc; qlen = QQ[-1]; cpyarr(QQ,qlen,Q); QQ = bmp->Qarr; for(count=1,k=0; k= lll) { lll += 2*ALEN; temp = Q + lll; aux = temp + lll; } } AA += ainc; QQ += qinc; } tlen = bigsqrt(Q,qlen,temp,&qlen,aux); qlen = multbig(temp,tlen,XX,xlen,Q,aux); xlen = modbig(Q,qlen,N,len,aux); cpyarr(Q,xlen,XX); cmp = cmparr(A,alen,XX,xlen); if(cmp == 0) return(0); cpyarr(A,alen,fact); if(cmp > 0) k = subarr(fact,alen,XX,xlen); else k = sub1arr(fact,alen,XX,xlen); cpyarr(N,len,temp); k = biggcd(fact,k,temp,len,aux); if(k > 1 || (k == 1 && fact[0] != 1)) { hilf[0] = count; return(k); } else return(0); } /*------------------------------------------------------------------*/ /* ** Multi-polynomial quadratic sieve factorization */ PRIVATE truc Fqsfact(argn) int argn; { truc *argptr; word2 *N; size_t buflen, buf2len; unsigned d; int len, n, sign, enough; argptr = argStkPtr-argn+1; if(argn >= 2 && *argStkPtr == zero) { doreport = 0; } else { doreport = 1; } len = bigref(argptr,&N,&sign); if(len == aERROR) { error(qsfactsym,err_int,*argptr); return(brkerr()); } d = banalfact(N,len); if(d != (unsigned)-1) return(mkfixnum(d)); #ifdef M_SMALL buflen = stkcheck() - STACKRES; #else buflen = scrbufSize * sizeof(word2); #endif buf2len = auxbufSize * sizeof(word2); enough = (buflen >= MEMCHUNK && buf2len >= MEMCHUNK); if(!enough) { error(qsfactsym,err_memev,voidsym); return(brkerr()); } if(len > ALEN) { error(qsfactsym,err_2big,*argptr); return(brkerr()); } #ifdef QTEST dbgf = fopen("qtest.log","w"); fprintf(dbgf,"N := "); showvect(dbgf,N,len); printf("hallo1\n"); #endif n = mpqsfactor(N,len,AriBuf); #ifdef QTEST fclose(dbgf); #endif return(mkint(0,AriBuf,n)); } /*-------------------------------------------------------------------*/ PRIVATE int mpqsfactor(N,len,fact) word2 *N, *fact; int len; { #ifdef M_SMALL word2 stackpiece[MEMCHUNK/sizeof(word2)]; #endif #ifdef BIGPRIMES QSBIGPRIMES qsbp; int bpv, idx; #endif BMDATA bm; SIEVEDATA sv; QSFBAS qsfb; word2 *buf1, *buf2, *hilf; size_t b1len, b2len, slen, restlen; long bitl; int k, alen, qlen, baslen, maxrows, srange, b0, b; int ret, again = 0; bitl = (len - 1)*16 + bitlen(N[len-1]); /* bitlength of N */ alen = len; qlen = (alen + 1)/2 + 2; /* !! */ #ifdef M_SMALL srange = (MEMCHUNK/sizeof(sievitem))/2; sv.srange = srange; sv.Sieve = (sievitem *)stackpiece; buf1 = AuxBuf; b1len = auxbufSize; buf2 = AriScratch; b2len = scrbufSize/2; hilf = AriScratch + b2len; #else /* M_LARGE */ buf1 = AuxBuf; restlen = auxbufSize; #ifdef BIGPRIMES idx = BPMAXIDX; while(--idx >= 0) { if(QSbpblen[idx] <= len) break; } b0 = sizeof(QSBP) + 2*sizeof(word2); b = ((2*auxbufSize/5)*sizeof(word2))/b0; while(idx > 0) { if(QShtablen[idx] <= b) break; else idx--; } bpv = (idx >= 0 ? 1 : 0); sv.useBigprim = bpv; if(bpv) { qlen = alen + 2; /* !! */ qsbp.maxrows = QShtablen[idx]; qsbp.QSBPdata = (QSBP *)AuxBuf; b1len = (qsbp.maxrows*sizeof(QSBP))/sizeof(word2); buf1 = AuxBuf + b1len; qsbp.tablen = QShconst[idx]; qsbp.hashtab = buf1; b2len = qsbp.tablen + 1; /* even */ buf1 += b2len; k = QSbpbmult[idx]; qsbp.bpbound = k*BIGPRIMEBOUND0; sv.qsbig = &qsbp; restlen = auxbufSize - (b1len + b2len); } else sv.qsbig = NULL; #endif /* BIGPRIMES */ nochmal: srange = MINSRANGE; if(bitl > 40) srange += (bitl-40)*(3*bitl)/2; if(bitl > 80) srange += (bitl-80)*(3*bitl)/2; if(again) { srange -= srange/5; } /* srange = bitl*100; srange = MINSRANGE; if(bitl > 64) srange += (bitl-64)*(bitl/5)*16; */ /* somewhat arbitrary */ if(srange > MAXSRANGE) srange = MAXSRANGE; if(2*srange*sizeof(sievitem) > (restlen/3)*sizeof(word2)) srange = (restlen/6)*sizeof(word2)/sizeof(sievitem); srange &= ~0x3; /* make it a multiple of 4 */ sv.srange = srange; sv.Sieve = (sievitem *)buf1; slen = (2*srange)/sizeof(word2); buf1 += slen; b1len = restlen - slen; buf2 = AriScratch; if(b1len/8 > scrbufSize) { b1len -= scrbufSize; hilf = buf1 + b1len; b2len = scrbufSize - 16; } else if((scrbufSize/2)*sizeof(word2) > MEMCHUNK) { b2len = scrbufSize - MEMCHUNK/sizeof(word2); hilf = buf2 + b2len; } else { b2len = scrbufSize/2; hilf = buf2 + b2len; } #endif /* M_LARGE */ maxrows = bm_alloc(buf1,b1len,buf2,b2len,&bm,alen,qlen); b0 = maxrows/16; b = 1 + (bitl*bitl)/384; if(bitl > 160) b += (b*(bitl-160))/80; if(again) b -= 1; if(b > b0) b = b0; bm.vlen = b; baslen = b*16 - 2; for(k=0; k<=baslen; k++) bm.piv[k] = baslen-k; /****** bm.piv[k] = k; *********************/ sv.fbp = &qsfb; qsfb.fbas = bm.fbas = hilf; qsfb.baslen = bm.baslen = baslen; qsfb.fbroot = hilf + b*16; qsfb.fblog = (sievitem *)(hilf + b*32); hilf += b * (32 + sizeof(sievitem)*16/sizeof(word2)); ret = qsfact1(N,len,fact,&bm,&sv,hilf); if(ret == 0 && again == 0 && bitl <= 144) { again = 1; goto nochmal; } else if(ret >= 0) return ret; else return 0; } /*---------------------------------------------------------------*/ /* ** If factor is found, it is stored in fact and its ** length is returned; ** if no factor found, returns 0 ** if interrupted, returns -1 */ PRIVATE int qsfact1(N,len,fact,bmp,qsp,hilf) word2 *N, *fact, *hilf; int len; BMDATA *bmp; SIEVEDATA *qsp; { #ifdef BIGPRIMES QSBIGPRIMES *qsbigp; QPOLY Qpol2; word2 Work2[2*ALEN+4]; word2 *hashtab, *tabptr, *QQ2, *AA2; word4 bigpbound = 0; word4 u; int sgn2; int count2 = 0; int useBigprim; #endif QPOLY Qpol; QSFBAS *fbp; word2 Q0[HLEN], Q1[HLEN], Work[2*ALEN+4]; word2 *fbase, *fbroot, *QQ, *AA; word2 *NN, *hilf1; sievitem *fblog, *sieve, *sptr; word4 cofac, v; int res, haveres, shrieks, maxshrieks; int k, n, n8, baslen, qlen, qvlen, srange, count, count1, sgn, xi; unsigned p,a; sievitem tol,target; QQ = Work + 1; AA = Work + (ALEN+4); fbp = qsp->fbp; fbase = fbp->fbas; baslen = factorbase(N,len,fbase,fbp->baslen,&p); if(p > 1) { /* found small prime divisor */ fact[0] = p; return(1); } fbp->baslen = baslen; fbroot = fbp->fbroot; fbroot[0] = 1; fblog = fbp->fblog; n8 = N[0] & 0x7; fblog[0] = (n8 == 1 ? 3 : (n8 == 5 ? 2 : 1)); for(k=1; kqpol = &Qpol; sieve = qsp->Sieve; srange = qsp->srange; qlen = startqq(N,len,srange,Q0,hilf); tol = fblog[baslen-1]; #ifdef BIGPRIMES useBigprim = qsp->useBigprim; if(useBigprim) { QQ2 = Work2 + 1; AA2 = Work2 + (ALEN+4); Qpol2.NNlen = len; cpyarr(N,len,Qpol2.NN); qsbigp = qsp->qsbig; bigpbound = qsbigp->bpbound; u = fbase[baslen-1]; u *= u; if(bigpbound > u) { bigpbound = u; } tol = lbitlen(bigpbound) + (len-BPMINLEN); /* somewhat arbitrary */ hashtab = qsbigp->hashtab; for(k=qsbigp->tablen, tabptr=hashtab; k>0; k--) *tabptr++ = 0xFFFF; qsbigp->row = 0; cpyarr(Q0,qlen,qsbigp->Q0); qsbigp->Q0[-1] = qlen; } #endif target = bit_length(N,len)/2 + lbitlen((word4)srange) - tol; if(doreport) qs0mess(srange,fbase[baslen-1],baslen); maxshrieks = (baslen < 64 ? 32 : 32 + (baslen/2 - 32)/bitlen(baslen)); for(v=1, count=count1=shrieks=0; shrieks 0) { /* Q0 divides N */ cpyarr(Q0,qlen,fact); return(qlen); } else if(res < 0) { /* possibly Q0 not prime */ if(doreport) tick('\''); if(++shrieks>=maxshrieks) break; else goto nochmal; } dosieve(qsp); /* collect sieve results */ for(sptr=sieve,xi=-srange; xi= target) { haveres = 0; Qpol.xi = xi; qvlen = quadvalue(&Qpol,QQ,&sgn); if(!qvlen) { /****** N square? ************/ if(doreport) tick('`'); continue; } cofac = smooth(QQ,fbase,baslen); if(cofac == 1) { if((++count1 & 0x3) == 1) if(doreport) tick('.'); qresitem(&Qpol,AA); haveres = 1; } #ifdef BIGPRIMES else if(useBigprim && (cofac < bigpbound) && (cofac > 1)) { res = hashbigp(qsbigp,cofac,&Qpol,&Qpol2,hilf); if(res > 0) { if((++count2 & 0x3) == 1) if(doreport) tick(':'); qresitem(&Qpol,AA); quadvalue(&Qpol2,QQ2,&sgn2); qresitem(&Qpol2,AA2); sgn = (sgn == sgn2 ? 0 : -1); combinebp(N,len,cofac,QQ,AA,QQ2,AA2,hilf); haveres = 1; } } #endif /* BIGPRIMES */ if(haveres) { count++; bm_insert(bmp,QQ,sgn,AA,hilf); if(gausselim(bmp)) { shrieks++; if(doreport) tick('!'); n = getfactor(N,len,bmp,fact,hilf); if(n > 0) { #ifdef BIGPRIMES if(useBigprim) { if(doreport) qs2mess(v,count,count2); } else #endif if(doreport) qs1mess(v,count); return(n); } if(shrieks >= maxshrieks) break; } } } } if(doreport) counttick(v,bmp); } /* check if N is a perfect square */ NN = hilf + 1; hilf1 = hilf + len + 2; cpyarr(N,len,NN); k = is_square(NN,len,fact,hilf1); return(k); } /*---------------------------------------------------------------*/ PRIVATE int dosieve(qsp) SIEVEDATA *qsp; { QPOLY *qpol; QSFBAS *fbp; sievitem *sieve, *sptr, *fblog; word2 *fbas, *fbroot, *aa, *bb, *cc; word4 u; unsigned a1, ainv, b1, binv, p, r, r1, s, xi, xi0, srange, srange2; int k, alen, blen, clen, baslen; sievitem z; srange = qsp->srange; srange2 = 2*srange; sieve = qsp->Sieve; qpol = qsp->qpol; aa = qpol->aa; alen = aa[-1]; bb = qpol->bb; blen = bb[-1]; cc = qpol->cc; clen = cc[-1]; fbp = qsp->fbp; fbas = fbp->fbas; baslen = fbp->baslen; fbroot = fbp->fbroot; fblog = fbp->fblog; z = fblog[0]; sieve[0] = sieve[srange2-1] = 0; xi0 = ((cc[0]&1) == (srange&1) ? 0 : 1); for(sptr=sieve+xi0, xi=xi0+1; xi= s ? r1 - s : r1 + (p-s)); for(sptr=sieve+xi0,xi=xi0; xi= s ? r1 - s : r1 + (p-s)); for(sptr=sieve+xi0,xi=xi0; xiQSBPdata; hashtab = qsbigp->hashtab; idx = prim % (qsbigp->tablen); row0 = hashtab[idx]; if(row0 == 0xFFFF) { row = qsbigp->row; if(row < qsbigp->maxrows) hashtab[idx] = row; qsdata[row].bprime = prim; qsdata[row].x = qpolp->xi; qlen = qpolp->qq[-1]; cpyarr(qpolp->qq,qlen,Qtemp); q0 = qsbigp->Q0; q0len = q0[-1]; qlen = subarr(Qtemp,qlen,q0,q0len); qsdata[row].qdiff = big2long(Qtemp,qlen); qsbigp->row = ++row; return(0); } else if(prim == qsdata[row0].bprime) { qpolp2->xi = qsdata[row0].x; qdiff = qsdata[row0].qdiff; plen = long2big(qdiff,pp); q0 = qsbigp->Q0; q0len = q0[-1]; cpyarr(q0,q0len,Qtemp); qlen = addarr(Qtemp,q0len,pp,plen); mkquadpol(Qtemp,qlen,qpolp2,hilf); return(1); } return(-1); } /*---------------------------------------------------------------*/ /* ** Hypothesis: QQ and QQ2 smooth (with respect to factor base) upto the factor bigprim; ** QQ = AA**2 mod N, QQ2 = AA2**2 mod N ** The function combines these data to produce (destructively) ** QQ and AA, such that QQ is smooth and QQ = AA**2 mod N */ PRIVATE int combinebp(N,len,bigprim,QQ,AA,QQ2,AA2,hilf) word2 *N; int len; word4 bigprim; word2 *QQ, *AA, *QQ2, *AA2, *hilf; { word2 pp[2]; word2 *xtemp, *ytemp, *ztemp; int alen, a2len, plen, pinvlen, qlen, q2len, rlen; qlen = QQ[-1]; q2len = QQ2[-1]; xtemp = hilf; ytemp = xtemp + 2*len; ztemp = ytemp + len; hilf += 5*len; plen = long2big(bigprim,pp); qlen = divbig(QQ,qlen,pp,plen,xtemp,&rlen,hilf); cpyarr(xtemp,qlen,QQ); q2len = divbig(QQ2,q2len,pp,plen,xtemp,&rlen,hilf); cpyarr(xtemp,q2len,QQ2); qlen = multbig(QQ,qlen,QQ2,q2len,xtemp,hilf); cpyarr(xtemp,qlen,QQ); QQ[-1] = qlen; alen = AA[-1]; a2len = AA2[-1]; alen = multbig(AA,alen,AA2,a2len,xtemp,hilf); alen = modbig(xtemp,alen,N,len,hilf); pinvlen = modinverse(pp,plen,N,len,ytemp,hilf); alen = multbig(xtemp,alen,ytemp,pinvlen,ztemp,hilf); alen = modbig(ztemp,alen,N,len,hilf); cpyarr(ztemp,alen,AA); return(AA[-1] = alen); } /*---------------------------------------------------------------*/ #endif /* BIGPRIMES */ /*---------------------------------------------------------------*/ /* ** Calculates a start q-value, which is ** approx sqrt(sqrt(2*N)/srange) = sqrt(sqrt(N/2)/(srange/2)) */ PRIVATE int startqq(N,len,srange,qq,hilf) word2 *N,*qq,*hilf; int len; unsigned srange; { word2 NN[ALEN],q0[HLEN]; word2 rr; unsigned sroot; int k, len1, dum; cpyarr(N,len,NN); len1 = shrarr(NN,len,1); k = bigsqrt(NN,len1,q0,&dum,hilf); k = bigsqrt(q0,k,qq,&dum,hilf); sroot = intsqrt((word4)(srange/2))+1; /* sroot < 2**16 */ k = divarr(qq,k,sroot,&rr); return(k); } /*---------------------------------------------------------------*/ /* ** Calculates the smallest odd prime qq, which is >= q0 ** and such that jacobi(N,qq) = 1. ** The result is stored in the buffer qq, ** return value is the length of qq. ** hilf is a buffer for auxiliary variables, whose length ** must be >= 11*max(len,q0len) */ PRIVATE int nextqq(N,len,q0,q0len,qq,hilf) word2 *N, *q0, *qq, *hilf; int len, q0len; { word2 *NN, *QQ, *aux; unsigned bound; int qqlen, len0; qqlen = q0len; cpyarr(q0,q0len,qq); qq[0] |= 0x1; /* make it odd */ bound = (qqlen > 2 ? 0xFFFF : 0x7FF); nochmal: while(trialdiv(qq,qqlen,3,bound)) qqlen = incarr(qq,qqlen,2); len0 = (len > qqlen ? len : qqlen+1); NN = hilf; QQ = hilf + len0; aux = QQ + len0; cpyarr(N,len,NN); cpyarr(qq,qqlen,QQ); if(jacobi(0,NN,len,QQ,qqlen,aux) == 1) { if(qqlen <= 2) { if(prime32(big2long(qq,qqlen))) return(qqlen); } else if(rabtest(qq,qqlen,aux)) { /* not 100% certain that qq is prime */ return(qqlen); } } qqlen = incarr(qq,qqlen,2); goto nochmal; } /*---------------------------------------------------------------*/ /* ** Calculates the smallest prime qq = 3 mod 4, which is >= q0 ** and such that jacobi(N,qq) = 1. ** The result is stored in the buffer qq, ** return value is the length of qq. ** hilf is a buffer for auxiliary variables, whose length ** must be >= 11*max(len,q0len) */ #if 0 PRIVATE int next_qq(N,len,q0,q0len,qq,hilf) word2 *N, *q0, *qq, *hilf; int len, q0len; { word2 *NN, *QQ, *aux; unsigned bound; int qqlen, len0; qqlen = q0len; cpyarr(q0,q0len,qq); qq[0] |= 0x3; /* make it = 3 mod 4 */ bound = (qqlen > 2 ? 0xFFFF : 0x7FF); nochmal: while(trialdiv(qq,qqlen,3,bound)) qqlen = incarr(qq,qqlen,4); len0 = (len > qqlen ? len : qqlen+1); NN = hilf; QQ = hilf + len0; aux = QQ + len0; cpyarr(N,len,NN); cpyarr(qq,qqlen,QQ); if(jacobi(0,NN,len,QQ,qqlen,aux) == 1) { if(qqlen <= 2) { if(prime32(big2long(qq,qqlen))) return(qqlen); } else if(rabtest(qq,qqlen,aux)) { /* not 100% certain that qq is prime */ return(qqlen); } } qqlen = incarr(qq,qqlen,4); goto nochmal; } #endif /*---------------------------------------------------------------*/ /* ** (p,plen) must be an odd prime such that jacobi(N,p) = 1. ** sptr is a pointer to a struct QPOLY which must contain in the ** fields NNlen and NN[] the number N to be factored. ** The function calculates the coefficients of a quadratic polynomial ** Q(x) = a*x*x + 2*b*x - c ** such that a = p*p and N = b*b + a*c ** The inverse of (p,len) mod NN is also calculated. ** Return value: ** 0 if OK ** 1 if p and N are not relatively prime ** -1 in case of error */ PRIVATE int mkquadpol(p,plen,sptr,hilf) word2 *p, *hilf; int plen; QPOLY *sptr; { word2 *N, *xx, *zz, *aux; int len, qilen, p2len, blen, b2len, clen, rlen, cmp; N = sptr->NN; len = sptr->NNlen; xx = hilf; zz = xx + len; aux = zz + 4*plen; sptr->qq[-1] = plen; cpyarr(p,plen,sptr->qq); /* now calculate inverse of (p,plen) mod (N,len) */ qilen = modinverse(p,plen,N,len,xx,aux); if(qilen == 0) { /* p divides N */ return(1); } else { cpyarr(xx,qilen,sptr->qinv); sptr->qinv[-1] = qilen; } /* coefficient a is square of p */ p2len = multbig(p,plen,p,plen,sptr->aa,hilf); sptr->aa[-1] = p2len; /* coefficient b is square root of N mod p*p */ blen = fp2Sqrt(p,plen,N,len,zz,aux); /** blen = p2sqrt(p,plen,N,len,zz,aux); **/ sptr->bb[-1] = blen; cpyarr(zz,blen,sptr->bb); /* calculate c as (N - b*b)/a */ b2len = multbig(sptr->bb,blen,sptr->bb,blen,zz,aux); cpyarr(N,len,xx); cmp = cmparr(xx,len,zz,b2len); if(cmp < 0) { /* this case should not happen */ return(-2); } len = subarr(xx,len,zz,b2len); clen = divbig(xx,len,sptr->aa,p2len,sptr->cc,&rlen,aux); sptr->cc[-1] = clen; if(rlen != 0) { /* then probably p was not prime */ return(-1); } return(0); } /*---------------------------------------------------------------*/ /* ** polp describes a polynomial F(X) = a*X*X + 2*b*X - c, ** polp->xi is an argument xi for this function ** quadvalue calculates F(xi). ** The value F(xi) is stored in QQ and *signp; ** the length of QQ is stored in QQ[-1] ** and is the return value. */ PRIVATE int quadvalue(polp,QQ,signp) QPOLY *polp; word2 *QQ; int *signp; { word2 ww1[ALEN], ww2[ALEN]; word2 *aa, *bb, *cc; unsigned u; int x, sgn, sgnx, cmp, lenax, len, alen, blen, clen; x = polp->xi; sgnx = (x < 0 ? -1 : 0); u = (sgnx ? -x : x); aa = polp->aa; alen = aa[-1]; bb = polp->bb; blen = bb[-1]; cc = polp->cc; clen = cc[-1]; lenax = multlarr(aa,alen,u,ww1); cpyarr(bb,blen,ww2); blen = shlarr(ww2,blen,1); if(!sgnx) { len = addarr(ww1,lenax,ww2,blen); sgn = 0; } else if(cmparr(ww1,lenax,ww2,blen) >= 0) { len = subarr(ww1,lenax,ww2,blen); sgn = -1; } else { len = sub1arr(ww1,lenax,ww2,blen); sgn = 0; } len = multlarr(ww1,len,u,ww1); if(len == 0) sgn = 0; else sgn = (sgnx ? -sgn-1 : sgn); if(!sgn) { cmp = cmparr(ww1,len,cc,clen); if(cmp >= 0) { len = subarr(ww1,len,cc,clen); sgn = 0; } else { len = sub1arr(ww1,len,cc,clen); sgn = -1; } } else { len = addarr(ww1,len,cc,clen); sgn = -1; } *signp = sgn; cpyarr(ww1,len,QQ); return(QQ[-1] = len); } /*------------------------------------------------------------------*/ /* ** Product of all primes B1 < p <= B2 ** and all integers n with isqrt(B1) < n <= isqrt(B2) ** B1 < B2 must be 16-bit integers */ PRIVATE int ppexpo(B1,B2,xx) unsigned B1, B2; word2 *xx; { unsigned m1,m2,k; int len; m1 = intsqrt(B1) + 1; if(m1 < 2) m1 = 2; m2 = intsqrt(B2); xx[0] = 1; len = 1; for(k=m1; k<=m2; k++) len = multarr(xx,len,k,xx); if(B1 & 1) B1++; for(k=B1+1; k<=B2; k+=2) { if(prime16(k)) len = multarr(xx,len,k,xx); } return len; } /*---------------------------------------------------------------*/ PRIVATE int multlarr(x,n,a,y) word2 *x, *y; int n; unsigned a; { #ifdef M_LARGE word4 a0, a1, u, v, carry; int i; if(a <= 0xFFFF) return(multarr(x,n,a,y)); #ifdef M32_64 return(mult4arr(x,n,a,y)); #else /* !M32_64 */ carry = 0; a0 = a & 0xFFFF; a1 = a >> 16; for(i=0; i> 16; carry >>= 16; carry += v; } if(carry) { *y++ = carry & 0xFFFF; n++; if(carry >>= 16) { *y = carry; n++; } } return(n); #endif /* ?M32_64 */ #else /* !M_LARGE; in M_SMALL we always have a < 2**16 */ return(multarr(x,n,a,y)); #endif /* ?M_LARGE */ } /*---------------------------------------------------------------*/ /* ** polp describes a polynomial F(X) = a*X*X + 2*b*X - c, ** where a = q*q and b*b + a*c = N. Let qinv := q**-1 mod N. ** The following equation holds: ** q*q*F(x) = (a*x + b)**2 mod N ** qresitem calculates AA := (a*x + b)*qinv mod N. ** the length of AA is stored in AA[-1]. */ PRIVATE int qresitem(polp,AA) QPOLY *polp; word2 *AA; { word2 ww0[2*ALEN], ww1[ALEN], ww2[ALEN], hilf[ALEN+1]; word2 *aa, *bb, *qinv, *N; unsigned u; int x, sgnx, lenax, len, alen, blen, qlen, nlen; x = polp->xi; sgnx = (x < 0 ? -1 : 0); u = (sgnx ? -x : x); aa = polp->aa; alen = aa[-1]; bb = polp->bb; blen = bb[-1]; qinv = polp->qinv; qlen = qinv[-1]; N = polp->NN; nlen = polp->NNlen; lenax = multlarr(aa,alen,u,ww1); cpyarr(ww1,lenax,ww2); if(!sgnx) { len = addarr(ww2,lenax,bb,blen); } else if(cmparr(ww2,lenax,bb,blen) >= 0) { len = subarr(ww2,lenax,bb,blen); } else { len = sub1arr(ww2,lenax,bb,blen); } len = multbig(ww2,len,qinv,qlen,ww0,hilf); len = modbig(ww0,len,N,nlen,hilf); cpyarr(ww0,len,AA); return(AA[-1] = len); } /*---------------------------------------------------------------*/ /* ** Calculates a square root of x mod p**2 ** Hypothesis: p prime = 3 mod 4, jacobi(x,p) = 1 ** The result is stored in z, its length is returned ** The buffer z must have a length >= 4*plen. ** ** The square root z is calculated using the formula ** z = x ** ((p*p - p + 2)/4) mod p**2 */ #if 0 PRIVATE int p2sqrt(p,plen,x,xlen,z,hilf) word2 *p, *x, *z, *hilf; int plen, xlen; { word2 *xx, *ex, *p2, *aux; int exlen, p2len, zlen; xx = hilf; p2len = 2*plen; p2 = xx + (xlen > p2len ? xlen : p2len); ex = p2 + p2len; aux = ex + p2len; p2len = multbig(p,plen,p,plen,p2,aux); cpyarr(x,xlen,xx); xlen = modbig(xx,xlen,p2,p2len,aux); cpyarr(p2,p2len,ex); exlen = subarr(ex,p2len,p,plen); exlen = incarr(ex,exlen,2); exlen = shrarr(ex,exlen,2); zlen = modpower(xx,xlen,ex,exlen,p2,p2len,z,aux); return(zlen); } #endif /*------------------------------------------------------------------*/ /* ** Returns 0 if (N,len) is not a square ** If return value k > 0, then (N,len) is the square of (root,k) */ PRIVATE int is_square(N,len,root,hilf) word2 *N, *root, *hilf; int len; { unsigned M = 15015; /* M=3*5*7*11*13 */ unsigned a; int k, rlen; if(len <= 0) return 0; if((N[0] & 1) == 0) { if((N[0] & 0x3) != 0) return 0; } else if((N[0] & 0x7) != 1) return 0; a = modarr(N,len,M); if(jac(a,13) == -1 || jac(a,11) == -1 || jac(a,7) == -1 || jac(a,5) == -1 || jac(a,3) == -1) return 0; k = bigsqrt(N,len,root,&rlen,hilf); if(rlen == 0) return k; else return 0; } /*------------------------------------------------------------------*/ PRIVATE truc Fecfactor(argn) int argn; { struct vector *vec; truc *ptr; truc *argptr; truc obj; word2 *N, *z, *xx, *x0, *cc, *hilf; word2 aa[2]; word4 u; unsigned v, bound, bound2, anz; word4 bigbound; int k, m, n, nlen, alen, xlen, x0len, zlen, sign, bitl; EPOINT Epoint[MAXDIFF/2 + 1]; ECN ecN; int mhdiff, ret, usebpv; /* ** parse and examine arguments of ec_factorize */ argptr = argStkPtr-argn+1; if(argn >= 2 && *argStkPtr == zero) { doreport = 0; argn--; } else { doreport = 1; if(argn == 4) argn--; } nlen = bigref(argptr,&N,&sign); if(nlen == aERROR) { error(ecfactsym,err_int,*argptr); return brkerr(); } else if(nlen >= aribufSize/10) { error(ecfactsym,err_ovfl,*argptr); return brkerr(); } else if(nlen == 0) { return zero; } else { u = banalfact(N,nlen); if(u != (unsigned)-1) return(mkfixnum(u)); } bitl = (nlen-1)*16 + bitlen(N[nlen-1]); bound = 1; bigbound = 1; if(argn>=2 && *FLAGPTR(argptr+1) == fVECTOR) { vec = (struct vector *)TAddress(argptr+1); n = vec->len; if(n != 2) { error(ecfactsym,"vector of length 2 expected",argptr[1]); return brkerr(); } ptr = &(vec->ele0); if(chkints(ecfactsym,ptr,2) == aERROR) return(brkerr()); n = bigref(ptr,&z,&sign); if(n <= 1 && n) { bound = *z; if(bound < 50) bound = 50; } n = bigref(ptr+1,&z,&sign); if(n <= 2) { bigbound = big2long(z,n); if(bigbound > 0 && bigbound < 97) bigbound = 100; } argptr += 2; argn -= 2; } else { argptr++; argn -= 1; } if(argn >= 1) { n = bigref(argptr,&z,&sign); if(n == aERROR) { error(ecfactsym,err_int,*argptr); return brkerr(); } else if(n <= 1 && n) { anz = *z; } else { anz = 0xFFFF; } } else { anz = (bitl <= 64 ? 64 : bitl); } if(bound == 1) { bound = 100; if(bitl > 32) bound += (bitl-32)*16; } else if(bound < 50) bound = 50; else if(bound > 64000) bound = 64000; if(bigbound == 0) { usebpv = 0; } else if(bigbound == 1) { usebpv = (bitl > 64 ? 1 : 0); } else { usebpv = 1; } if(usebpv) { if(bigbound == 1) { m = 2 + (bound >> 9); if(m > 10) m = 10; bigbound = m*bound; } if(bigbound > 0x1000000) { bigbound = 0x1000000; } } /* ** memory allocation */ x0 = AriScratch; xx = x0 + 2*nlen + 2; cc = x0 + 4*nlen + 4; hilf = x0 + 6*nlen + 6; if(usebpv) mhdiff = ecbpvalloc(Epoint,AuxBuf,auxbufSize,nlen,&bigbound); ecN.N = N; ecN.nlen = nlen; ecN.aa = aa; ecN.cc = cc; if(doreport) { if(usebpv) ec1mess(bound, bigbound); else ec0mess(bound); } /* ** choose random curve */ u = 3 + random4(0x1000000); alen = long2big(u,aa); v = 1 + random2(64000); /* ** choose random initial point (x0,x0len) */ /* here nlen > 1 */ x0[nlen-1] = 1; for(k=0; k<=nlen-2; k++) x0[k] = random2(0xFFFF); x0len = nlen; obj = zero; for(k=0; k bound) B2 = bound; exlen = ppexpo(B1,B2,ex); zlen = pemult(xx,xlen,ex,exlen,aa,alen,N,len,zz,hilf); xlen = (zlen >= 0 ? zlen : -zlen-1); cpyarr(zz,xlen,xx); if(zlen < 0) { *pbound = B2; if(cmparr(N,len,zz,xlen) == 0 || (zz[0]==1 && xlen == 1)) zlen = 0; break; } } return zlen; } /*-----------------------------------------------------------------*/ PRIVATE int ecbpvalloc(pEpoint, buf, buflen, nlen, pbound) EPOINT *pEpoint; word2 *buf; size_t buflen; int nlen; unsigned *pbound; { word2 *xx, *yy; size_t anz0; int maxdiff, k, m, n; unsigned bound; k = ECMAXIDX - 1; bound = *pbound; if(bound > ECbpbound[k]) { bound = ECbpbound[k]; } else { while(k > 0 && bound <= ECbpbound[k-1]) k--; } maxdiff = ECmdiff[k]; anz0 = buflen/(nlen + 1); if(anz0 <= maxdiff) { if(anz0 <= ECmdiff[0]) return -1; for(m=k-1; m>=0; m--) { if(anz0 > ECmdiff[m]) { maxdiff = ECmdiff[m]; if(bound > ECbpbound[m]) bound = ECbpbound[m]; break; } } } xx = buf; yy = buf + nlen + 1; m = 2*nlen + 2; for(n=0; n<=maxdiff/2; n++) { pEpoint[n].xx = xx; pEpoint[n].yy = yy; xx += m; yy += m; } *pbound = bound; return maxdiff/2; } /*-----------------------------------------------------------------*/ /* ** big prime variation for EC factoring ** In case a factor is found, it is stored in xx, ** with return value -xlen-1. ** If no factor found, return value is >= 0 */ PRIVATE int ecfactbpv(pecN,pEpoint,pbound,hdiff,xx,xlen,hilf) ECN *pecN; EPOINT *pEpoint; word2 *xx, *hilf; int xlen, hdiff; unsigned *pbound; { EPOINT *pZ; EPOINT *pEtemp; word2 *zz; int k, ret; unsigned q, bound; int found = 0; pZ = pEpoint; cpyarr(xx,xlen,pZ->xx); pZ->xlen = xlen; pZ->yy[0] = 1; pZ->ylen = 1; pEtemp = pEpoint + 1; cpyarr(xx,xlen,pEtemp->xx); pEtemp->xlen = xlen; pEtemp->yy[0] = 1; pEtemp->ylen = 1; ret = ECNdup(pecN,pEtemp,hilf); if(ret == -2) { zz = pEtemp->yy; xlen = pEtemp->ylen; found = 1; *pbound = 2; goto ausgang; } for(k=2; k<=hdiff; k++) { cpyarr(pEtemp->xx,pEtemp->xlen,pEpoint[k].xx); cpyarr(pEtemp->yy,pEtemp->ylen,pEpoint[k].yy); pEpoint[k].xlen = pEtemp->xlen; pEpoint[k].ylen = pEtemp->ylen; } ret = ECNdup(pecN,pEpoint+2,hilf); if(ret == -2) { zz = pEpoint[2].yy; xlen = pEpoint[2].ylen; found = 1; *pbound = 2; goto ausgang; } for(k=3; k<=hdiff; k++) { ret = ECNadd(pecN,pEpoint+k,pEpoint+(k-1),hilf); if(ret == -2) { zz = pEpoint[k].yy; xlen = pEpoint[k].ylen; found = 1; q = fact16(k); *pbound = (q ? q : k); goto ausgang; } } q = 1; bound = *pbound-2; while(q <= bound) { k = 1; q += 2; while(!prime32(q)) { q += 2; k++; } ret = ECNadd(pecN,pZ,pEpoint+k,hilf); if(ret == -2) { xlen = pZ->ylen; zz = pZ->yy; *pbound = q; found = 1; break; } } ausgang: if(found) { cpyarr(zz,xlen,xx); return(-xlen-1); } else { return xlen; } } /*-----------------------------------------------------------------*/ /* ** Given x, a and N, calculates c such that ** c = x**3 + a*x**2 + x mod N ** a and N are handed in through pecN, the result ** c is stored in pecN ** Return value is the length of c ** If c == 0, a factor of N may be found. This factor ** is then stored in place of c and -2 is returned. ** If c == 0 and no factor is found, the return value is 0 */ PRIVATE int ECNx2c(pecN,xx,xlen,hilf) ECN *pecN; word2 *xx, *hilf; int xlen; { word2 *yy, *zz, *N; int alen, ylen, zlen, nlen; if(xlen == 0) return 0; N = pecN->N; nlen = pecN->nlen; yy = hilf; zz = hilf + nlen + 2; hilf += 3*nlen + 4; if(xlen > nlen) xlen = modbig(xx,xlen,N,nlen,hilf); alen = pecN->alen; cpyarr(pecN->aa,alen,yy); ylen = addarr(yy,alen,xx,xlen); zlen = multbig(yy,ylen,xx,xlen,zz,hilf); zlen = modbig(zz,zlen,N,nlen,hilf); ylen = incarr(zz,zlen,1); cpyarr(zz,ylen,yy); /* yy contains x**2 + a*x + 1 */ zlen = multbig(yy,ylen,xx,xlen,zz,hilf); zlen = modbig(zz,zlen,N,nlen,hilf); if(zlen == 0) { cpyarr(N,nlen,zz); if(ylen == 0) { cpyarr(xx,xlen,yy); ylen = xlen; } ylen = biggcd(yy,ylen,zz,nlen,hilf); if(yy[0] == 1 && ylen == 1) return 0; else { cpyarr(yy,ylen,pecN->cc); pecN->clen = ylen; return -2; } } cpyarr(zz,zlen,pecN->cc); return (pecN->clen = zlen); } /*-----------------------------------------------------------------*/ /* ** Calculates destructively Z1 := Z1 + Z2 ** Returns pZ1->xlen ** >= 0, if result is an affine point ** -1, if Origin ** -2, if divisor of N detected ** This divisor is then stored in (pZ1->yy,pZ1->ylen) */ /* (x,y) := (x1,y1) add (x2,y2) m := mod_inverse(x2-x1,N); m := (y2 - y1)*m mod N; x := (c*m*m - a - x1 - x2) mod N; y := (- y1 - m*(x - x1)) mod N; */ PRIVATE int ECNadd(pecN,pZ1,pZ2,hilf) ECN *pecN; EPOINT *pZ1, *pZ2; word2 *hilf; { word2 *N, *xx, *yy, *zz, *slope; int x1len, x2len, zlen, nlen, slen; int xlen, ylen, cmp, cmp1; x1len = pZ1->xlen; x2len = pZ2->xlen; if(x2len < 0 || x1len < 0) { if(x2len == -1) return pZ1->xlen; else if(x2len == -2) { cpyarr(pZ2->yy,pZ2->ylen,pZ1->yy); pZ1->ylen = pZ2->ylen; return (pZ1->xlen = -2); } if(x1len == -1) { cpyarr(pZ2->yy,pZ2->ylen,pZ1->yy); pZ1->ylen = pZ2->ylen; cpyarr(pZ2->xx,x2len,pZ1->xx); return (pZ1->xlen = x2len); } else if(x1len == -2) return x1len; } N = pecN->N; nlen = pecN->nlen; xx = hilf; yy = hilf + 2*nlen + 2; zz = hilf + 4*nlen + 4; slope = hilf + 6*nlen + 6; hilf += 8*nlen + 8; xlen = x2len; cpyarr(pZ2->xx,xlen,xx); cmp = cmparr(pZ1->xx,x1len,pZ2->xx,x2len); if(cmp > 0) { xlen = sub1arr(xx,xlen,pZ1->xx,x1len); xlen = sub1arr(xx,xlen,N,nlen); } else if(cmp < 0) xlen = subarr(xx,xlen,pZ1->xx,x1len); /* xx contains (x2 - x1) */ ylen = pZ2->ylen; cpyarr(pZ2->yy,ylen,yy); cmp1 = cmparr(pZ1->yy,pZ1->ylen,yy,ylen); if(cmp1 > 0) { ylen = sub1arr(yy,ylen,pZ1->yy,pZ1->ylen); ylen = sub1arr(yy,ylen,N,nlen); } else if(cmp1 < 0) ylen = subarr(yy,ylen,pZ1->yy,pZ1->ylen); /* yy contains (y2 - y1) */ if(cmp == 0) { if(cmp1 == 0) return ECNdup(pecN,pZ1,hilf); else { cpyarr(N,nlen,xx); ylen = biggcd(yy,ylen,xx,nlen,hilf); cpyarr(yy,ylen,pZ1->yy); pZ1->ylen = ylen; return (pZ1->xlen = -2); } } slen = modinverse(xx,xlen,N,nlen,slope,hilf); if(slen == 0) { cpyarr(N,nlen,yy); xlen = biggcd(xx,xlen,yy,nlen,hilf); cpyarr(xx,xlen,pZ1->yy); pZ1->ylen = xlen; return (pZ1->xlen = -2); } slen = modmultbig(slope,slen,yy,ylen,N,nlen,xx,hilf); cpyarr(xx,slen,slope); /* slope = (y2-y1)/(x2-x1) */ zlen = multbig(slope,slen,slope,slen,zz,hilf); zlen = modbig(zz,zlen,N,nlen,hilf); cpyarr(zz,zlen,xx); zlen = multbig(xx,zlen,pecN->cc,pecN->clen,zz,hilf); /* zz contains c*slope**2 */ cpyarr(pZ1->xx,x1len,xx); xlen = addarr(xx,x1len,pZ2->xx,x2len); xlen = addarr(xx,xlen,pecN->aa,pecN->alen); xlen = modnegbig(xx,xlen,N,nlen,hilf); /* xx contains -a - x1 - x2 */ zlen = addarr(zz,zlen,xx,xlen); zlen = modbig(zz,zlen,N,nlen,hilf); /* zz contains new x = c*slope**2 - a - x1 - x2 */ cpyarr(pZ1->xx,x1len,xx); cmp = cmparr(zz,zlen,xx,x1len); if(cmp >= 0) xlen = sub1arr(xx,x1len,zz,zlen); else { xlen = subarr(xx,x1len,zz,zlen); xlen = sub1arr(xx,xlen,N,nlen); } /* xx contains (x - x1) */ cpyarr(zz,zlen,pZ1->xx); pZ1->xlen = zlen; zlen = multbig(xx,xlen,slope,slen,zz,hilf); /* zz contains slope*(x - x1) */ zlen = addarr(zz,zlen,pZ1->yy,pZ1->ylen); zlen = modnegbig(zz,zlen,N,nlen,hilf); /* zz contains (-y1 - slope*(x - x1)) mod N */ cpyarr(zz,zlen,pZ1->yy); pZ1->ylen = zlen; return pZ1->xlen; } /*-----------------------------------------------------------------*/ /* ** Calculates destructively Z := Z + Z ** Returns pZ->xlen ** >= 0, if result is an affine point ** -1, if Origin ** -2, if divisor of N detected ** This divisor is then stored in (pZ->yy,pZ->ylen) */ /* z := 2*c*y1; m := mod_inverse(z,N); Pprim := (((3*x1 + 2*a)*x1) + 1) mod N; m := Pprim*m mod N; x := (c*m*m - a - 2*x1) mod N; y := (- y1 - m*(x - x1)) mod N; */ PRIVATE int ECNdup(pecN,pZ,hilf) ECN *pecN; EPOINT *pZ; word2 *hilf; { word2 *N, *xx, *yy, *zz, *slope; int x1len, alen, nlen, slen; int xlen, ylen, zlen, cmp; if(pZ->ylen == 0) return (pZ->xlen = -1); else if(pZ->xlen < 0) return pZ->xlen; N = pecN->N; nlen = pecN->nlen; xx = hilf; yy = hilf + nlen + 2; zz = hilf + 2*nlen + 4; slope = hilf + 4*nlen + 6; hilf += 5*nlen + 8; zlen = multbig(pecN->cc,pecN->clen,pZ->yy,pZ->ylen,zz,hilf); zlen = shiftarr(zz,zlen,1); /* zz contains 2*c*y1 */ slen = modinverse(zz,zlen,N,nlen,slope,hilf); /* slope contains 1/(2*c*y1) */ if(slen == 0) { cpyarr(N,nlen,yy); zlen = biggcd(zz,zlen,yy,nlen,hilf); cpyarr(zz,zlen,pZ->yy); pZ->ylen = zlen; return (pZ->xlen = -2); } x1len = pZ->xlen; cpyarr(pZ->xx,x1len,xx); xlen = multarr(xx,x1len,3,xx); alen = pecN->alen; cpyarr(pecN->aa,alen,yy); ylen = shiftarr(yy,alen,1); xlen = addarr(xx,xlen,yy,ylen); /* xx contains (3*x1 + 2*a) */ zlen = multbig(xx,xlen,pZ->xx,x1len,zz,hilf); zlen = incarr(zz,zlen,1); zlen = modbig(zz,zlen,N,nlen,hilf); /* zz contains Pprim = ((3*x1 + 2*a)*x1 + 1) mod N */ cpyarr(zz,zlen,xx); slen = multbig(xx,zlen,slope,slen,zz,hilf); slen = modbig(zz,slen,N,nlen,hilf); cpyarr(zz,slen,slope); /* slope contains Pprim/(2*c*y1) */ zlen = multbig(slope,slen,slope,slen,zz,hilf); zlen = modbig(zz,zlen,N,nlen,hilf); cpyarr(zz,zlen,xx); zlen = multbig(xx,zlen,pecN->cc,pecN->clen,zz,hilf); /* zz contains c*slope**2 */ cpyarr(pZ->xx,x1len,xx); xlen = shiftarr(xx,x1len,1); xlen = addarr(xx,xlen,pecN->aa,alen); xlen = modnegbig(xx,xlen,N,nlen,hilf); /* xx contains -a - 2*x1 */ zlen = addarr(zz,zlen,xx,xlen); zlen = modbig(zz,zlen,N,nlen,hilf); /* zz contains new x = c*slope**2 - a - 2*x1 */ cpyarr(pZ->xx,x1len,xx); cmp = cmparr(zz,zlen,xx,x1len); if(cmp >= 0) xlen = sub1arr(xx,x1len,zz,zlen); else { xlen = subarr(xx,x1len,zz,zlen); xlen = sub1arr(xx,xlen,N,nlen); } /* xx contains (x - x1) */ cpyarr(zz,zlen,pZ->xx); pZ->xlen = zlen; zlen = multbig(xx,xlen,slope,slen,zz,hilf); /* zz contains slope*(x - x1) */ zlen = addarr(zz,zlen,pZ->yy,pZ->ylen); zlen = modnegbig(zz,zlen,N,nlen,hilf); /* zz contains new y = (-y1 - slope*(x - x1)) mod N */ cpyarr(zz,zlen,pZ->yy); pZ->ylen = zlen; return pZ->xlen; } /*------------------------------------------------------------------*/ #ifdef ETEST /* ** Calculates destructively Z := (ex,exlen)*Z ** Returns pZ->xlen ** >= 0, if result is an affine point ** -1, if Origin ** -2, if divisor of N detected ** This divisor is then stored in (pZ->yy,pZ->ylen) */ PRIVATE int ECNmult(pecN, pZ, ex, exlen, hilf) ECN *pecN; EPOINT *pZ; word2 *ex, *hilf; int exlen; { word2 *xx, *yy; int xlen, ylen, nlen, m, bitl, k, ret; EPOINT Z0; if(exlen == 0) { pZ->xlen = -1; return -1; } nlen = pecN->nlen; xlen = Z0.xlen = pZ->xlen; ylen = Z0.ylen = pZ->ylen; m = (xlen > nlen ? xlen : nlen); m = (ylen > m ? ylen : m); xx = hilf; yy = hilf + m + 2; hilf += 2*m + 4; Z0.xx = xx; Z0.yy = yy; cpyarr(pZ->xx,xlen,xx); cpyarr(pZ->yy,ylen,yy); bitl = (exlen-1)*16 + bitlen(ex[exlen-1]); for(k=bitl-2; k>=0; k--) { ret = ECNdup(pecN,pZ,hilf); if(ret == -2) return ret; if(testbit(ex,k)) { ret = ECNadd(pecN,pZ,&Z0,hilf); if(ret == -2) return ret; } } return pZ->xlen; } #endif /********************************************************************/ aribas165b/src/aritz.c0000644000076600000240000027205514660570651013677 0ustar ottostaff/****************************************************************/ /* file aritz.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de WWW http://www.mathematik.uni-muenchen.de */ /****************************************************************/ /* ** aritz.c ** functions for polynomials ** and for arithmetic in GF(2**n) ** ** date of last change ** ** 2002-04-07: created ** 2003-03-05: gf2n functions ** 2007-04-04: gf2X functions ** 2007-09-08: bugfix in gf2X_mod ** 2007-09-18: gf2polsquare ** 2007-10-01: gf2X_divide ** 2010-02-24: ZnX functions */ #include "common.h" #define GF2XARITH // #define ZnXARITH // #define POLYARITH /*-----------------------------------------------------------------*/ /* field extension Fp[sqrt(D)] */ typedef struct { word2 *pp; int plen; word2 *D; int dlen; } FP2D; typedef struct { word2 *xx; int xlen; word2 *yy; int ylen; } PAIRXY; /*-----------------------------------------------------------------*/ /* setbit and testbit suppose that vv is an array of word2 */ #define setbit(vv,i) vv[(i)>>4] |= (1 << ((i)&0xF)) #define testbit(vv,i) (vv[(i)>>4] & (1 << ((i)&0xF))) /*-----------------------------------------------------------------*/ #define MULTFLAG 0 #define DIVFLAG 1 #define MODFLAG 2 #define MODNFLAG 4 #define DDIVFLAG (DIVFLAG | MODFLAG) /*-----------------------------------------------------------------*/ PUBLIC void iniaritz (void); PUBLIC truc gf2nzero, gf2none; PUBLIC truc gf2nintsym, gf2n_sym; #ifdef POLYARITH PUBLIC truc polmultsym, polNmultsym; PUBLIC truc polmodsym, polNmodsym, poldivsym, polNdivsym; #endif PUBLIC truc addgf2ns (truc *ptr); PUBLIC truc multgf2ns (truc *ptr); PUBLIC truc exptgf2n (truc *ptr); PUBLIC truc divgf2ns (truc *ptr); PUBLIC int fpSqrt (word2 *pp, int plen, word2 *aa, int alen, word2 *zz, word2 *hilf); PUBLIC int fp2Sqrt (word2 *pp, int plen, word2 *aa, int alen, word2 *zz, word2 *hilf); PUBLIC unsigned fp_sqrt (unsigned p, unsigned a); #ifdef ZnXARITH PRIVATE truc znXmultsym, znXsqsym; PRIVATE truc znXddivsym, znXdivsym, znXmodsym, znXgcdsym; PRIVATE truc znXmodpowsym; #endif PRIVATE truc Fgf2nint (void); #ifdef ZnXARITH PRIVATE truc FznXmult (void); PRIVATE truc FznXsquare (void); PRIVATE truc FznXdivide (void); PRIVATE truc FznXdiv (void); PRIVATE truc FznXmod (void); PRIVATE truc FznXgcd (void); PRIVATE truc FznXmodpow (void); PRIVATE truc znXpolmult (truc *mptr, truc *argptr); PRIVATE truc znXpolsquare (truc *mptr, truc *argptr); PRIVATE truc znXpolmodpow (truc *mptr, truc *FF, truc *exptr, truc *GG); PRIVATE truc znXpoldiv (truc *mptr, truc *argptr, int mode); PRIVATE truc znXpolmod (truc *mptr, truc *argptr); PRIVATE truc znXpolgcd (truc *mptr, truc *argptr); PRIVATE truc znXnormalize (truc *mptr, truc *GG, int glen); PRIVATE int znXredraw (truc *mptr, truc *GG, int glen); PRIVATE int znXsquare0 (truc *mptr, truc *FF, int len1, truc *PP); PRIVATE int znXmult0 (truc *mptr, truc *FF, int len1, truc *GG,int len2, truc *PP); PRIVATE int znXmod0 (truc *mptr, truc *FF, int flen, truc *GG, int glen); PRIVATE truc znXdivmodsymb (int mode); PRIVATE int chkznXmultargs (truc sym, truc *argptr); #endif #ifdef POLYARITH PRIVATE truc Fpolmult (void); PRIVATE truc FpolNmult (void); PRIVATE truc Fpolmod (void); PRIVATE truc FpolNmod (void); PRIVATE truc Fpoldiv (void); PRIVATE truc FpolNdiv (void); PRIVATE int chkpolmultargs (truc sym, truc *argptr); PRIVATE int chkpoldivargs (truc sym, truc *argptr); PRIVATE truc multintpols (truc *argptr, int mode); PRIVATE truc modintpols (truc *argptr, int mode); #endif PRIVATE int gf2polmod (word2 *x, int n, word2 *y, int m); PRIVATE int gf2polmult (word2 *x, int n, word2 *y, int m, word2 *z); PRIVATE int gf2poldivide (word2 *x, int n, word2 *y, int m, word2 *z, int *rlenptr); PRIVATE int gf2poldiv (word2 *x, int n, word2 *y, int m, word2 *z); PRIVATE int gf2ninverse (word2 *x, int n, word2 *z, word2 *uu); PRIVATE int gf2npower (word2 *x, int n, word2 *y, int m, word2 *z, word2 *hilf); PRIVATE int gf2polsquare (word2 *x, int n, word2 *z); PRIVATE int gf2polmodpow (word2 *x, int n, word2 *y, int m, word2 *f, int flen, word2 *z, word2 *hilf); PRIVATE int gf2polgcd (word2 *x, int n, word2 *y, int m); PRIVATE int gf2polgcdx (word2 *x, int n, word2 *y, int m, word2 *z, int *zlenptr, word2 *hilf); PRIVATE int gf2polirred (word2 *x, int n, word2 *y, word2 *hilf); PRIVATE int gf2polirred1 (word2 *x, int n, word2 *y, word2 *hilf); PRIVATE int gf2ntrace (word2 *x, int n); PRIVATE int shiftleft1 (word2 *x, int n); PRIVATE int bitxorshift (word2 *x, int n, word2 *y, int m, int s); PRIVATE unsigned gf2polfindirr (int n); PRIVATE truc gf2ndegsym, gf2npolsym, gf2ninisym, gf2ntrsym, maxgf2nsym; PRIVATE truc Fgf2ninit (void); PRIVATE truc Fgf2ndegree (void); PRIVATE truc Fgf2nfieldpol (void); PRIVATE truc Fgf2ntrace (void); PRIVATE truc Fmaxgf2n (void); PRIVATE int gf2nmod (word2 *x, int n); PRIVATE truc gf2Xmulsym, gf2Xsqsym; PRIVATE truc gf2Xddivsym, gf2Xdivsym, gf2Xmodsym, gf2Xgcdsym; PRIVATE truc gf2Xmpowsym, gf2Xprimsym; PRIVATE truc Fgf2Xmult (void); PRIVATE truc Fgf2Xsquare (void); PRIVATE truc Fgf2Xdivide (void); PRIVATE truc Fgf2Xdiv (void); PRIVATE truc Fgf2Xmod (void); PRIVATE truc Fgf2Xgcd (void); PRIVATE truc Fgf2Xmodpow (void); PRIVATE truc Fgf2Xprimtest (void); /*----------------------------------------------------*/ PRIVATE void fp2Dmult (FP2D *pfp2D, PAIRXY *pZ1, PAIRXY *pZ2, word2 *hilf); PRIVATE void fp2Dsquare (FP2D *pfp2D, PAIRXY *pZ, word2 *hilf); PRIVATE void fp2Dpower (FP2D *pfp2D, PAIRXY *pZ, word2 *ex, int exlen, word2 *hilf); PRIVATE long nonresdisc (word2 *pp, int plen, word2 *aa, int alen, word2 *hilf); PRIVATE int fpSqrt58 (word2 *pp, int plen, word2 *aa, int alen, word2 *zz, word2 *hilf); PRIVATE int fpSqrt14 (word2 *pp, int plen, word2 *aa, int alen, word2 *zz, word2 *hilf); PRIVATE unsigned fp_sqrt14 (unsigned p, unsigned a); PRIVATE void fp2pow (unsigned p, unsigned D, unsigned *uu, unsigned n); PRIVATE truc Ffpsqrt (void); PRIVATE truc fpsqrtsym; /* #define NAUSKOMM */ #ifdef NAUSKOMM PRIVATE truc gggsym, gg1sym, gg2sym; PRIVATE truc Fggg (void); PRIVATE truc Fgg1 (void); PRIVATE truc Fgg2 (void); #endif /*------------------------------------------------------------------*/ PUBLIC void iniaritz() { word2 x[1]; fpsqrtsym = newsymsig("gfp_sqrt", sFBINARY, (wtruc)Ffpsqrt, s_2); gf2nzero = mk0gf2n(x,0); x[0] = 1; gf2none = mk0gf2n(x,1); gf2nintsym = newsym ("gf2nint", sTYPESPEC, gf2nzero); gf2n_sym = new0symsig("gf2nint", sFBINARY, (wtruc)Fgf2nint, s_1); gf2ntrsym = newsymsig("gf2n_trace",sFBINARY, (wtruc)Fgf2ntrace, s_1); gf2ninisym = newsymsig("gf2n_init", sFBINARY, (wtruc)Fgf2ninit, s_1); gf2ndegsym = newsymsig("gf2n_degree", sFBINARY, (wtruc)Fgf2ndegree, s_0); gf2npolsym = newsymsig("gf2n_fieldpol",sFBINARY,(wtruc)Fgf2nfieldpol,s_0); maxgf2nsym = newsymsig("max_gf2nsize",sFBINARY, (wtruc)Fmaxgf2n, s_0); #ifdef GF2XARITH gf2Xmulsym = newsymsig("gf2X_mult", sFBINARY, (wtruc)Fgf2Xmult, s_2); gf2Xsqsym = newsymsig("gf2X_square", sFBINARY, (wtruc)Fgf2Xsquare, s_1); gf2Xddivsym= newsymsig("gf2X_divide", sFBINARY, (wtruc)Fgf2Xdivide, s_2); gf2Xdivsym = newsymsig("gf2X_div", sFBINARY, (wtruc)Fgf2Xdiv, s_2); gf2Xmodsym = newsymsig("gf2X_mod", sFBINARY, (wtruc)Fgf2Xmod, s_2); gf2Xgcdsym = newsymsig("gf2X_gcd", sFBINARY, (wtruc)Fgf2Xgcd, s_2); gf2Xmpowsym = newsymsig("gf2X_modpower", sFBINARY, (wtruc)Fgf2Xmodpow, s_3); gf2Xprimsym = newsymsig("gf2X_primetest",sFBINARY,(wtruc)Fgf2Xprimtest,s_1); #endif /* GF2XARITH */ #ifdef ZnXARITH znXmultsym = newsymsig("ZnX_mult", sFBINARY, (wtruc)FznXmult, s_3); znXsqsym = newsymsig("ZnX_square",sFBINARY, (wtruc)FznXsquare, s_2); znXddivsym = newsymsig("ZnX_divide",sFBINARY, (wtruc)FznXdivide, s_3); znXdivsym = newsymsig("ZnX_div", sFBINARY, (wtruc)FznXdiv, s_3); znXmodsym = newsymsig("ZnX_mod", sFBINARY, (wtruc)FznXmod, s_3); znXgcdsym = newsymsig("ZnX_gcd", sFBINARY, (wtruc)FznXgcd, s_3); znXmodpowsym= newsymsig("ZnX_modpower",sFBINARY, (wtruc)FznXmodpow,s_4); #endif #ifdef POLYARITH polmultsym = newsymsig("pol_mult", sFBINARY, (wtruc)Fpolmult, s_2); polNmultsym= newintsym("pol_mult() mod", sFBINARY,(wtruc)FpolNmult); polmodsym = newsymsig("pol_mod", sFBINARY, (wtruc)Fpolmod, s_2); polNmodsym = newintsym("pol_mod() mod", sFBINARY,(wtruc)FpolNmod); poldivsym = newsymsig("pol_div", sFBINARY, (wtruc)Fpoldiv, s_2); polNdivsym = newintsym("pol_div() mod", sFBINARY,(wtruc)FpolNdiv); #endif /* POLYARITH */ #ifdef NAUSKOMM gggsym = newsymsig("ggg", sFBINARY, (wtruc)Fggg, s_2); gg1sym = newsymsig("gg1", sFBINARY, (wtruc)Fgg1, s_2); gg2sym = newsymsig("gg2", sFBINARY, (wtruc)Fgg2, s_3); #endif } /*-------------------------------------------------------------------*/ PRIVATE truc Ffpsqrt() { word2 *pp, *aa, *hilf; int plen, alen, len, sign; if(chkints(fpsqrtsym,argStkPtr-1,2) == aERROR) return(brkerr()); plen = bigref(argStkPtr-1,&pp,&sign); if(plen == 0 || (pp[0] & 1) == 0 || (plen == 1 && pp[0] <= 2)) { error(fpsqrtsym,err_oddprim,argStkPtr[-1]); return brkerr(); } else if(plen > scrbufSize/16) { error(fpsqrtsym,err_ovfl,voidsym); return brkerr(); } aa = AriScratch; alen = bigretr(argStkPtr,aa,&sign); if(sign) alen = modnegbig(aa,alen,pp,plen,AriBuf); else if(alen >= plen) alen = modbig(aa,alen,pp,plen,AriBuf); hilf = AriScratch + plen + 2; len = fpSqrt(pp,plen,aa,alen,AriBuf,hilf); if(len < 0) { error(scratch("gfp_sqrt(p,a)"), "p not prime or a not a square mod p",voidsym); return brkerr(); } return mkint(0,AriBuf,len); } /*-------------------------------------------------------------------*/ #ifdef NAUSKOMM /*-------------------------------------------------------------------*/ PRIVATE truc Fggg() { #if 1 word2 *pp, *aa, *hilf; size_t N; int plen, alen, len, sign; if(chkints(gggsym,argStkPtr-1,2) == aERROR) return(brkerr()); aa = AriScratch; plen = bigref(argStkPtr-1,&pp,&sign); alen = bigretr(argStkPtr,aa,&sign); N = 2*plen + alen; if(N > scrbufSize/16) { error(gggsym,err_ovfl,voidsym); return brkerr(); } hilf = AriScratch + N; len = fp2Sqrt(pp,plen,aa,alen,AriBuf,hilf); if(len < 0) { error(gggsym,"sqrt mod p*p failed",voidsym); return brkerr(); } return mkint(0,AriBuf,len); #else return zero; #endif } /*-------------------------------------------------------------------*/ PRIVATE truc Fgg1() { word2 *pp, *aa, *hilf; size_t N; int plen, alen, len, sign; if(chkints(gg1sym,argStkPtr-1,2) == aERROR) return(brkerr()); aa = AriScratch; plen = bigref(argStkPtr-1,&pp,&sign); alen = bigretr(argStkPtr,aa,&sign); N = plen + alen; if(N > scrbufSize/12) { error(gg1sym,err_ovfl,voidsym); return brkerr(); } hilf = AriScratch + N; if(sign) alen = modnegbig(aa,alen,pp,plen,hilf); len = fpSqrt14(pp,plen,aa,alen,AriBuf,hilf); if(len < 0) { error(gg1sym,"sqrt mod p failed",voidsym); return brkerr(); } return mkint(0,AriBuf,len); } /*-------------------------------------------------------------------*/ /* ** gg2(p,D,c) calculates (c + sqrt D)**(p+1)/2 in Fp[sqrt D] ** and returns its x-coordinate */ PRIVATE truc Fgg2() { word2 *pp, *D, *ex, *xx, *yy, *hilf; int N, plen, dlen, exlen, xlen, sign; FP2D fp2D; PAIRXY Z; if(chkints(gg1sym,argStkPtr-2,3) == aERROR) return(brkerr()); D = hilf = AriScratch; plen = bigref(argStkPtr-2,&pp,&sign); dlen = bigretr(argStkPtr-1,D,&sign); fp2D.pp = pp; fp2D.plen = plen; fp2D.D = D; fp2D.dlen = dlen; xx = AriBuf; N = plen + dlen + 2; ex = hilf + 2*N; yy = hilf + 4*N; hilf += 5*N; xlen = bigretr(argStkPtr,xx,&sign); Z.xx = xx; Z.xlen = xlen; Z.yy = yy; yy[0] = 1; Z.ylen = 1; cpyarr(pp,plen,ex); exlen = incarr(ex,plen,1); exlen = shiftarr(ex,exlen,-1); fp2Dpower(&fp2D,&Z,ex,exlen,hilf); xlen = Z.xlen; return mkint(0,xx,xlen); } /*-------------------------------------------------------------------*/ #endif /* NAUSKOMM */ /*-----------------------------------------------------------------*/ /* ** Hypothesis: (pp,plen) an odd prime, (aa, alen) a QR mod (pp,plen) ** Function calculates a square root (zz,zlen) of (aa,alen) ** (aa, alen) is reduced mod (pp,plen) ** space in zz must be at least 2*plen ** Return value is zlen ** In case of error, -1 is returned */ PUBLIC int fpSqrt(pp,plen,aa,alen,zz,hilf) word2 *pp, *aa, *zz, *hilf; int plen, alen; { word2 *ex, *uu, *vv; int m8, exlen, zlen, ulen, vlen; if((plen < 1) || (pp[0] & 1) != 1) return -1; if(cmparr(pp,plen,aa,alen) <= 0) { alen = modbig(aa,alen,pp,plen,hilf); } if(!alen) return 0; m8 = (pp[0] & 0x7); if(m8 == 5) { return fpSqrt58(pp,plen,aa,alen,zz,hilf); } else if(m8 == 1) { return fpSqrt14(pp,plen,aa,alen,zz,hilf); } /******** else p = 3 mod 4 ********/ ex = hilf; uu = hilf + plen + 2; vv = hilf + 3*plen + 4; hilf += 5*plen + 6; cpyarr(pp,plen,ex); exlen = shiftarr(ex,plen,-2); /* ex = (p-3)/4 */ ulen = modpower(aa,alen,ex,exlen,pp,plen,uu,hilf); /* a**((p-3)/4) */ zlen = modmultbig(uu,ulen,aa,alen,pp,plen,zz,hilf); /* a**((p+1)/4 */ vlen = modmultbig(uu,ulen,zz,zlen,pp,plen,vv,hilf); /* a**((p-1)/2 */ if(vv[0] != 1 || vlen != 1) return -1; return zlen; } /*-----------------------------------------------------------------*/ /* ** Hypothesis: (pp,plen) an odd prime = 5 mod 8, ** (aa, alen) is a QR mod (pp,plen) ** Function calculates a square root (zz,zlen) of (aa,alen) ** Return value is zlen ** In case of error, -1 is returned */ PRIVATE int fpSqrt58(pp,plen,aa,alen,zz,hilf) word2 *pp, *aa, *zz, *hilf; int plen, alen; { word2 *ex, *uu, *vv, *ww; int zlen, exlen, ulen, vlen, wlen, cmp; ex = hilf; uu = hilf + plen + 2; vv = hilf + 3*plen + 4; ww = hilf + 5*plen + 6; hilf += 7*plen + 8; cpyarr(pp,plen,ex); exlen = shiftarr(ex,plen,-3); /* ex = (p - 5)/8 */ vlen = modpower(aa,alen,ex,exlen,pp,plen,vv,hilf); /* v = a**((p-5)/8) */ ulen = modmultbig(vv,vlen,aa,alen,pp,plen,uu,hilf); /* u = a**((p+3)/8) */ wlen = modmultbig(uu,ulen,vv,vlen,pp,plen,ww,hilf); /* w = a**((p-1)/4) */ if(ww[0] == 1 && wlen == 1) { cpyarr(uu,ulen,zz); zlen = ulen; } else { wlen = incarr(ww,wlen,1); cmp = cmparr(ww,wlen,pp,plen); if(cmp != 0) return -1; exlen = shiftarr(ex,exlen,1); exlen = incarr(ex,exlen,1); /* ex = (p - 1)/4 */ ww[0] = 2; wlen = 1; vlen = modpower(ww,wlen,ex,exlen,pp,plen,vv,hilf); zlen = modmultbig(uu,ulen,vv,vlen,pp,plen,ww,hilf); cpyarr(ww,zlen,zz); } if((zz[0] & 1) == 1) zlen = sub1arr(zz,zlen,pp,plen); return zlen; } /*-----------------------------------------------------------------*/ /* ** Hypothesis: (pp,plen) an odd prime = 1 mod 4, ** (aa, alen) is a QR mod (pp,plen) ** Function calculates a square root (zz,zlen) of (aa,alen) ** Return value is zlen ** In case of error, -1 is returned */ PRIVATE int fpSqrt14(pp,plen,aa,alen,zz,hilf) word2 *pp, *aa, *zz, *hilf; int plen, alen; { long c; word2 *ex, *D, *xx, *yy; int exlen, dlen, xlen, zlen, cmp; FP2D fp2D; PAIRXY Z; c = nonresdisc(pp,plen,aa,alen,hilf); if(c < 0) return -1; xx = zz; yy = hilf; D = hilf + 2*plen + 2; ex = hilf + 4*plen + 4; hilf += 5*plen + 6; xlen = long2big(c,xx); Z.xx = xx; Z.xlen = xlen; yy[0] = 1; Z.yy = yy; Z.ylen = 1; dlen = multbig(xx,xlen,xx,xlen,D,hilf); /* c**2 */ cmp = cmparr(D,dlen,aa,alen); if(cmp < 0) { dlen = sub1arr(D,dlen,aa,alen); dlen = modnegbig(D,dlen,pp,plen,hilf); } else { dlen = subarr(D,dlen,aa,alen); dlen = modbig(D,dlen,pp,plen,hilf); } fp2D.pp = pp; fp2D.plen = plen; fp2D.D = D; fp2D.dlen = dlen; cpyarr(pp,plen,ex); exlen = incarr(ex,plen,1); exlen = shiftarr(ex,exlen,-1); fp2Dpower(&fp2D,&Z,ex,exlen,hilf); if(Z.ylen != 0) return -1; else { zlen = Z.xlen; if((zz[0] & 1) == 1) zlen = sub1arr(zz,zlen,pp,plen); return zlen; } } /*---------------------------------------------------------------*/ /* ** returns square root of a mod p, where p is a prime ** Hypothesis: jac(a,p) = 1. ** p and a should be 16-bit numbers. */ PUBLIC unsigned fp_sqrt(p,a) unsigned p,a; { if((p & 3) == 3) return(modpow(a,(p+1)/4,p)); else return(fp_sqrt14(p,a)); } /*---------------------------------------------------------------*/ /* ** returns square root of a mod p, where p is a prime = 1 mod 4. ** Hypothesis: jac(a,p) = 1. ** p and a should be 16-bit numbers. */ PRIVATE unsigned fp_sqrt14(p,a) unsigned p,a; { word4 c; unsigned D, u; unsigned uu[2]; a = a % p; a = p - a; for(c=1; c < p; c++) { D = (unsigned)((c*c + a) % p); if(jac(D,p) == -1) break; } uu[0] = (unsigned)c; uu[1] = 1; fp2pow(p,D,uu,(p+1)/2); u = uu[0]; if(u & 1) u = p-u; return u; } /*---------------------------------------------------------------*/ /* ** calculates uu**n in the field Fp(sqrt(D)) ** Hypothesis: jac(D,p) = -1, ** p 16-bit prime ** (uu[0],uu[1]) is destructively replaced by result */ PRIVATE void fp2pow(p,D,uu,n) unsigned p,D; unsigned *uu; unsigned n; { word4 x,x0,y,y0,X,Y; if(n == 0) { uu[0] = 1; uu[1] = 0; return; } x = uu[0]; y = uu[1]; X = 1; Y = 0; while(n > 1) { if(n & 1) { x0 = X; y0 = (Y*y) % p; /* ** X = (X*x + D*y0) % p; ** Y = (x0*y + Y*x) % p; */ X *= x; X %= p; X += D*y0; X %= p; Y *= x; X %= p; Y += x0*y; Y %= p; } x0 = x; y0 = (y*y) % p; /* ** x = (x*x + D*y0) % p; ** y = (2*x0*y) % p; */ x *= x; x %= p; x += D*y0; x %= p; y *= x0; y %= p; y += y; y %= p; n >>= 1; } x0 = X; y0 = (Y*y) % p; /* ** uu[0] = (X*x + D*y0) % p; ** uu[1] = (X*y + Y*x) % p; */ X *= x; X %= p; X += D*y0; uu[0] = X % p; Y *= x; Y += x0*y; uu[1] = Y % p; } /*-----------------------------------------------------------------*/ /* ** Calculates a square root of (aa,alen) mod (pp,plen)**2 ** Hypothesis: pp odd prime, jacobi(aa,pp) = 1 */ /* z := fp_sqrt(p,a); xi := (z*z - a) div p; eta := mod_inverse(2*z,p); delta := xi*eta mod p; z := z - delta*p; return (z mod p**2); */ PUBLIC int fp2Sqrt(pp,plen,aa,alen,zz,hilf) word2 *pp, *aa, *zz, *hilf; int plen, alen; { word2 *xi, *eta, *delta, *ww; int m, xilen, elen, dlen, zlen, rlen, wlen, cmp, sign; m = 2*plen + 2; xi = hilf; eta = xi + m; delta = eta + m; ww = delta + m; hilf = ww + (alen >= m ? alen + 2: m); cpyarr(aa,alen,ww); wlen = modbig(ww,alen,pp,plen,hilf); zlen = fpSqrt(pp,plen,ww,wlen,zz,hilf); if(zlen < 0) /* error */ return zlen; xilen = multbig(zz,zlen,zz,zlen,xi,hilf); cmp = cmparr(xi,xilen,aa,alen); if(cmp >= 0) { xilen = subarr(xi,xilen,aa,alen); sign = 0; } else { xilen = sub1arr(xi,xilen,aa,alen); sign = MINUSBYTE; } xilen = divbig(xi,xilen,pp,plen,ww,&rlen,hilf); if(sign) { xilen = modnegbig(ww,xilen,pp,plen,hilf); } cpyarr(ww,xilen,xi); /* xi := (z*z - a) div p */ cpyarr(zz,zlen,ww); elen = shiftarr(ww,zlen,1); elen = modinverse(ww,elen,pp,plen,eta,hilf); /* eta = mod_inverse(2*z,p) */ dlen = modmultbig(xi,xilen,eta,elen,pp,plen,delta,hilf); /* delta := xi*eta mod p */ wlen = multbig(delta,dlen,pp,plen,ww,hilf); cmp = cmparr(zz,zlen,ww,wlen); if(cmp >= 0) { zlen = subarr(zz,zlen,ww,wlen); sign = 0; } else { zlen = sub1arr(zz,zlen,ww,wlen); sign = MINUSBYTE; } /* z := z - delta*p, sign! */ wlen = multbig(pp,plen,pp,plen,ww,hilf); if(sign == 0) zlen = modbig(zz,zlen,ww,wlen,hilf); else { zlen = modnegbig(zz,zlen,ww,wlen,hilf); } return zlen; } /*-----------------------------------------------------------------*/ /* ** returns a number c such that jacobi(c*c - (aa,alen),(pp,plen)) = -1 ** In case of error (possibly (pp,plen) not prime) returns -1 */ PRIVATE long nonresdisc(pp,plen,aa,alen,hilf) word2 *pp, *aa, *hilf; int plen, alen; { word4 c,v; word2 *xx, *yy; int k, vlen, xlen, cmp, sign, res; unsigned u; if(alen > plen) alen = modbig(aa,alen,pp,plen,hilf); if(!alen) return -1; xx = hilf; hilf += (plen >= alen ? plen : alen) + 2; yy = hilf; hilf += plen + 2; u = 0x1000; if(plen == 1 && pp[0] < u) { u = pp[0]; } c = random2(u); for(k=1; k<=60000; k++,c++) { v = c*c; vlen = long2big(v,xx); cmp = cmparr(aa,alen,xx,vlen); if(cmp > 0) { xlen = sub1arr(xx,vlen,aa,alen); sign = MINUSBYTE; } else if(cmp < 0) { xlen = subarr(xx,vlen,aa,alen); sign = 0; } else continue; cpyarr(pp,plen,yy); res = jacobi(sign,xx,xlen,yy,plen,hilf); if(res < 0) return c; if((k & 0xFF) == 0) { if(!rabtest(pp,plen,hilf)) break; } } return -1; } /*-----------------------------------------------------------------*/ /* ** Destructively calculates *pZ1 := (*pZ1) * (*pZ2) ** in the field given by *pfp2D */ PRIVATE void fp2Dmult(pfp2D,pZ1,pZ2,hilf) FP2D *pfp2D; PAIRXY *pZ1, *pZ2; word2 *hilf; { word2 *x0, *zz, *ww; int zlen, plen, wlen, x0len; plen = pfp2D->plen; x0 = hilf; zz = hilf + plen + 2; ww = hilf + 3*plen + 4; hilf += 5*plen + 6; /* x0 := x1 */ x0len = pZ1->xlen; cpyarr(pZ1->xx,x0len,x0); /* x1 := x1*x2 + y1*y2*D */ zlen = multbig(pZ1->yy,pZ1->ylen,pZ2->yy,pZ2->ylen,zz,hilf); zlen = modbig(zz,zlen,pfp2D->pp,plen,hilf); wlen = multbig(zz,zlen,pfp2D->D,pfp2D->dlen,ww,hilf); zlen = multbig(pZ1->xx,pZ1->xlen,pZ2->xx,pZ2->xlen,zz,hilf); wlen = addarr(ww,wlen,zz,zlen); wlen = modbig(ww,wlen,pfp2D->pp,plen,hilf); cpyarr(ww,wlen,pZ1->xx); pZ1->xlen = wlen; /* y1 := x0*y2 + y1*x2 */ wlen = multbig(x0,x0len,pZ2->yy,pZ2->ylen,ww,hilf); zlen = multbig(pZ1->yy,pZ1->ylen,pZ2->xx,pZ2->xlen,zz,hilf); wlen = addarr(ww,wlen,zz,zlen); wlen = modbig(ww,wlen,pfp2D->pp,plen,hilf); cpyarr(ww,wlen,pZ1->yy); pZ1->ylen = wlen; } /*-----------------------------------------------------------------*/ /* ** Destructively calculates *pZ := (*pZ)**2 ** in the field given by *pfp2D */ PRIVATE void fp2Dsquare(pfp2D,pZ,hilf) FP2D *pfp2D; PAIRXY *pZ; word2 *hilf; { word2 *x0, *zz, *ww; int zlen, plen, wlen, x0len; plen = pfp2D->plen; x0 = hilf; zz = hilf + plen + 2; ww = hilf + 3*plen + 4; hilf += 5*plen + 6; /* x0 := x */ x0len = pZ->xlen; cpyarr(pZ->xx,x0len,x0); /* x := x*x + y*y*D */ zlen = multbig(pZ->yy,pZ->ylen,pZ->yy,pZ->ylen,zz,hilf); zlen = modbig(zz,zlen,pfp2D->pp,plen,hilf); wlen = multbig(zz,zlen,pfp2D->D,pfp2D->dlen,ww,hilf); zlen = multbig(pZ->xx,pZ->xlen,pZ->xx,pZ->xlen,zz,hilf); wlen = addarr(ww,wlen,zz,zlen); wlen = modbig(ww,wlen,pfp2D->pp,plen,hilf); cpyarr(ww,wlen,pZ->xx); pZ->xlen = wlen; /* y := 2*x0*y */ zlen = multbig(x0,x0len,pZ->yy,pZ->ylen,zz,hilf); zlen = shiftarr(zz,zlen,1); zlen = modbig(zz,zlen,pfp2D->pp,plen,hilf); cpyarr(zz,zlen,pZ->yy); pZ->ylen = zlen; } /*-----------------------------------------------------------------*/ /* ** Destructively calculates *pZ := (*pZ)**(ex,exlen) ** in the field given by *pfp2D */ PRIVATE void fp2Dpower(pfp2D,pZ,ex,exlen,hilf) FP2D *pfp2D; PAIRXY *pZ; word2 *ex, *hilf; int exlen; { PAIRXY Z0; word2 *xx, *yy; int plen, bitl, k; int allowintr; if(exlen == 0) { pZ->xx[0] = 1; pZ->xlen = 1; pZ->ylen = 0; return; } plen = pfp2D->plen; xx = hilf; yy = hilf + 2*plen + 2; hilf += 4*plen + 4; /* z0 := z */ cpyarr(pZ->xx,pZ->xlen,xx); cpyarr(pZ->yy,pZ->ylen,yy); Z0.xx = xx; Z0.yy = yy; Z0.xlen = pZ->xlen; Z0.ylen = pZ->ylen; bitl = (exlen-1)*16 + bitlen(ex[exlen-1]); allowintr = (plen >= 16 && (exlen + plen >= 256) ? 1 : 0); for(k=bitl-2; k>=0; k--) { fp2Dsquare(pfp2D,pZ,hilf); if(testbit(ex,k)) fp2Dmult(pfp2D,pZ,&Z0,hilf); if(allowintr && INTERRUPT) { setinterrupt(0); reset(err_intr); } } return; } /*------------------------------------------------------------------*/ #ifdef ZnXARITH /*------------------------------------------------------------------*/ PRIVATE truc FznXmult() { int type; if(chkintnz(znXmultsym,argStkPtr-2) == aERROR) return brkerr(); type = chkznXmultargs(znXmultsym,argStkPtr-1); if(type == aERROR) return brkerr(); return znXpolmult(argStkPtr-2,argStkPtr-1); } /*------------------------------------------------------------------*/ PRIVATE truc FznXsquare() { int type; if(chkintnz(znXsqsym,argStkPtr-1) == aERROR) return brkerr(); type = *FLAGPTR(argStkPtr); if(type != fVECTOR) { error(znXsqsym,err_vect,*argStkPtr); return brkerr(); } if(chkintvec(znXsqsym,argStkPtr) == aERROR) return brkerr(); return znXpolsquare(argStkPtr-1,argStkPtr); } /*------------------------------------------------------------------*/ /* ** ZnX_modpower(p,F,ex,G) */ PRIVATE truc FznXmodpow() { int type; if(chkintnz(znXmodpowsym,argStkPtr-3) == aERROR) return brkerr(); if(chkint(znXmodpowsym,argStkPtr-1) == aERROR) return brkerr(); type = *FLAGPTR(argStkPtr-2); if(type != fVECTOR) { error(znXmodpowsym,err_vect,argStkPtr[-2]); return brkerr(); } if(chkintvec(znXmodpowsym,argStkPtr-2) == aERROR) return brkerr(); type = *FLAGPTR(argStkPtr); if(type != fVECTOR) { error(znXmodpowsym,err_vect,argStkPtr[0]); return brkerr(); } if(chkintvec(znXmodpowsym,argStkPtr) == aERROR) return brkerr(); return znXpolmodpow(argStkPtr-3,argStkPtr-2,argStkPtr-1,argStkPtr); } /*------------------------------------------------------------------*/ PRIVATE truc FznXdivide() { int type, mode; if(chkintnz(znXdivsym,argStkPtr-2) == aERROR) return brkerr(); type = chkznXmultargs(znXddivsym,argStkPtr-1); if(type == aERROR) return brkerr(); mode = DDIVFLAG; return znXpoldiv(argStkPtr-2,argStkPtr-1,mode); } /*------------------------------------------------------------------*/ PRIVATE truc FznXdiv() { int type, mode; if(chkintnz(znXdivsym,argStkPtr-2) == aERROR) return brkerr(); type = chkznXmultargs(znXdivsym,argStkPtr-1); if(type == aERROR) return brkerr(); mode = DIVFLAG; return znXpoldiv(argStkPtr-2,argStkPtr-1,mode); } /*------------------------------------------------------------------*/ PRIVATE truc FznXmod() { int type; if(chkintnz(znXmodsym,argStkPtr-2) == aERROR) return brkerr(); type = chkznXmultargs(znXmodsym,argStkPtr-1); if(type == aERROR) return brkerr(); return znXpolmod(argStkPtr-2,argStkPtr-1); } /*------------------------------------------------------------------*/ PRIVATE truc FznXgcd() { int type; if(chkintnz(znXgcdsym,argStkPtr-2) == aERROR) return brkerr(); type = chkznXmultargs(znXgcdsym,argStkPtr-1); if(type == aERROR) return brkerr(); return znXpolgcd(argStkPtr-2,argStkPtr-1); } /*------------------------------------------------------------------*/ PRIVATE truc znXpolsquare(mptr,argptr) truc *mptr; truc *argptr; { truc *workarr, *outarr, *ptr, *ptr1, *wptr; truc obj; int len, len1, k, i; unsigned mlen; len1 = *VECLENPTR(argptr); if(len1 == 0) return mkvect0(0); mlen = aribufSize/3 - 6; if(*FLAGPTR(mptr) == fBIGNUM && *BIGLENPTR(mptr) >= mlen) goto ovflexit; if(*mptr == zero) { error(znXmodsym,err_pint,*mptr); return brkerr(); } /* now len1 >= 1 */ workarr = arrayStkPtr+1; if(!ARRAYspace(3*len1-1)) { error(znXsqsym,err_memev,voidsym); return brkerr(); } ptr = VECTORPTR(argptr); wptr = workarr; for(i=0; i= mlen) goto ovflexit; *wptr++ = *ptr++; } /* initialize result array */ ptr = outarr = workarr + len1; len = 2*len1 - 1; for(i=0; i= mlen) goto ovflexit; if(*mptr == zero) { error(znXmodpowsym,err_pint,*mptr); return brkerr(); } flen = *VECLENPTR(Fptr); if(!flen) return mkvect0(0); glen = *VECLENPTR(Gptr); if(!glen) { error(znXmodpowsym,err_div,voidsym); return brkerr(); } arraySavePtr = arrayStkPtr; freelen = ARRAYmemavail(); if((freelen <= 5*glen) || (freelen <= flen + glen)) { error(znXmodpowsym,err_memev,voidsym); return brkerr(); } GG = arraySavePtr+1; FF = GG + glen; arrayStkPtr = arraySavePtr + (flen+glen); ptr1 = GG; ptr2 = VECTORPTR(Gptr); for(k=0; k= mlen) goto ovflexit; *ptr1++ = *ptr2++; } ptr1 = FF; ptr2 = VECTORPTR(Fptr); for(k=0; k= mlen) goto ovflexit; *ptr1++ = *ptr2++; } if(GG[glen-1] != constone) { /* normalize polynomial G */ res = znXnormalize(mptr,GG,glen); if (res == zero) { error(znXmodpowsym, "leading coeff of module not invertible ",GG[glen-1]); return brkerr(); } } /**************mm**************/ else { /* reduce big coeffs of G modulo *mptr */ aa = AriBuf; offsbb = (mlen + 6) & 0xFFFE; bb = AriBuf + offsbb; m2 = bigretr(mptr,aa,&sign2); for(k=0; k m2) { cpyarr(yy,m,bb); n = modbig(bb,m,aa,m2,AriScratch); obj = mkint(sign1,bb,n); GG[k] = obj; } } } if(flen >= glen) { flen = znXmod0(mptr,FF,flen,GG,glen); arrayStkPtr = arraySavePtr + (flen+glen); } PP = arrayStkPtr+1; TT = PP + glen; arrayStkPtr += 3*glen; ptr = PP; for(i=0; i<3*glen; i++) *ptr++ = zero; exlen = bigref(exptr,&xx,&sign); exlen2 = (exlen+1)/2; if(SAVEspace(exlen2) == NULL) { error(znXmodpowsym,err_memev,voidsym); return brkerr(); } else { nn = (word2*)saveStkPtr; cpyarr(xx,exlen,nn); } cpy4arr(FF,flen,PP); plen = flen; bitl = (exlen-1)*16 + bitlen(nn[exlen-1]); for(n=bitl-2; n>=0; n--) { /* TT := PP**2; TT := TT mod GG; PP := TT; */ tlen = znXsquare0(mptr,PP,plen,TT); plen = znXmod0(mptr,TT,tlen,GG,glen); cpy4arr(TT,plen,PP); if(testbit(nn,n)) { /* TT := PP*FF; TT := TT mod GG; PP := TT; */ tlen = znXmult0(mptr,FF,flen,PP,plen,TT); plen = znXmod0(mptr,TT,tlen,GG,glen); cpy4arr(TT,plen,PP); } if(!(n & 0xF) && INTERRUPT) { setinterrupt(0); reset(err_intr); } } obj = mkvect0(plen); ptr1 = VECTOR(obj); ptr2 = PP; for(k=0; k m2) { cpyarr(yy,m,bb); n = modbig(bb,m,aa,m2,AriScratch); obj = mkint(sign1,bb,n); GG[k] = obj; } } return glen; } /*------------------------------------------------------------------*/ /* ** Squares the polynomial (FF,len1) ** in the polynomial ring Z/(*mptr) ** and stores the result in the array PP, which ** must have length = 2*len1-1 */ PRIVATE int znXsquare0(mptr,FF,len1,PP) truc *mptr, *FF, *PP; int len1; { word2 *x, *y, *zz, *aa, *hilf; truc obj; int len, k, i, j0, j1; int n1, n2, n3, n, m, sign, sign1, sign2, sign3; unsigned mlen, offshilf; if(len1 <= 0) return 0; zz = AriBuf; n3 = bigretr(mptr,zz,&sign3); mlen = aribufSize/3 - 6; aa = AriBuf + ((mlen + 6) & 0xFFFE); offshilf = (scrbufSize/2) & 0xFFFE; len = 2*len1 - 1; for(k=0; k 0 && PP[len-1] == zero) len--; return len; } /*------------------------------------------------------------------*/ /* ** Multiplies the polynomial (FF,len1) by (GG,len2) ** in the polynomial ring Z/(*mptr) ** and stores the result in the array PP, which ** must have length = 2*(len1+len2) - 1 */ PRIVATE int znXmult0(mptr,FF,len1,GG,len2,PP) truc *mptr, *FF, *GG, *PP; int len1, len2; { truc obj; word2 *x, *y, *zz, *aa, *hilf; int len, k, i, j0, j1; int n1, n2, n3, n, m, sign, sign1, sign2, sign3; unsigned mlen, offshilf; zz = AriBuf; n3 = bigretr(mptr,zz,&sign3); mlen = aribufSize/3 - 6; aa = AriBuf + ((mlen + 6) & 0xFFFE); offshilf = (scrbufSize/2) & 0xFFFE; len = len1 + len2 - 1; for(k=0; k 0 && PP[len-1] == zero) len--; return len; } /*------------------------------------------------------------------*/ /* ** multiplies two integer polynomials given by argptr[0] and argptr[1] ** and mods them out modulo *mptr */ PRIVATE truc znXpolmult(mptr,argptr) truc *mptr; truc *argptr; { truc *ptr1, *ptr2; truc *workarr, *w2ptr, *outarr, *ptr, *wptr; truc obj; int len, len1, len2, k, i; unsigned mlen; len = *VECLENPTR(argptr); len2 = *VECLENPTR(argptr+1); if(len >= len2) { len1 = len; ptr1 = argptr; ptr2 = argptr + 1; } else { len1 = len2; len2 = len; ptr1 = argptr + 1; ptr2 = argptr; } /* now len1 >= len2, lenk = length of vector *ptrk */ if(len2 == 0) return mkvect0(0); /* now len2 >= 1 */ workarr = arrayStkPtr+1; if(!ARRAYspace(2*(len1+len2)-1)) { error(znXmultsym,err_memev,voidsym); return brkerr(); } mlen = aribufSize/3 - 6; if(*FLAGPTR(mptr) == fBIGNUM && *BIGLENPTR(mptr) >= mlen) goto ovflexit; ptr = VECTORPTR(ptr1); wptr = workarr; for(i=0; i= mlen) goto ovflexit; *wptr++ = *ptr++; } ptr = VECTORPTR(ptr2); wptr = w2ptr = workarr + len1; for(k=0; k= mlen) goto ovflexit; *wptr++ = *ptr++; } ptr = outarr = w2ptr + len2; len = len1 + len2 - 1; for(k=0; k len1) { if (mode == MODFLAG) return *argptr; else obj = mkvect0(0); if (mode == DIVFLAG) return obj; else { /* mode == DDIVFLAG */ WORKpush(obj); obj = mkvect0(2); vptr = VECTOR(obj); vptr[0] = WORKretr(); vptr[1] = *argptr; return obj; } } mlen = aribufSize/3 - 6; if(*FLAGPTR(mptr) == fBIGNUM && *BIGLENPTR(mptr) >= mlen) goto ovflexit; if(*mptr == zero) { error(znXdivmodsymb(mode),err_pint,*mptr); return brkerr(); } workarr = arrayStkPtr+1; if(!ARRAYspace(len1 + len2)) { error(znXdivmodsymb(mode),err_memev,voidsym); return brkerr(); } w2ptr = workarr + len1; offsbb = (mlen + 6) & 0xFFFE; offshilf = (scrbufSize/2) & 0xFFFE; ptr1 = workarr; ptr2 = VECTORPTR(argptr); for(k=0; k= mlen) goto ovflexit; *ptr1++ = *ptr2++; } ptr1 = w2ptr; ptr2 = VECTORPTR(argptr+1); for(k=0; k= mlen) goto ovflexit; *ptr1++ = *ptr2++; } aa = AriBuf; bb = AriBuf + offsbb; if(w2ptr[len2-1] != constone) { leadcorr = 1; leadptr = w2ptr + len2 - 1; n = bigretr(leadptr,bb,&signL); m2 = bigref(mptr,&zz,&sign2); m = modinverse(bb,n,zz,m2,aa,AriScratch); if (m==0) { error(znXdivmodsymb(mode), "leading coeff must be invertible mod n",w2ptr[len2-1]); return brkerr(); } obj = mkint(signL,aa,m); *leadptr = obj; for(k=0; k=0; k--) { n = bigretr(workarr+len2-1+k,aa,&sign); m2 = bigref(mptr,&zz,&sign2); n = modbig(aa,n,zz,m2,AriScratch); if(!n) continue; for(j=0; j<=len2-2; j++) { m = bigref(w2ptr+j,&yy,&sign1); if(!m) continue; m = multbig(aa,n,yy,m,AriScratch,AriScratch+offshilf); sign1 = (sign == sign1 ? MINUSBYTE : 0); /* sign of the negative product */ m1 = bigretr(workarr+k+j, bb, &sign2); m = addsarr(bb,m1,sign2,AriScratch,m,sign1,&sign3); obj = mkint(sign3,bb,m); workarr[k+j] = obj; } } if (mode & MODFLAG) { len4 = len2 - 1; for(k=0; k0 && workarr[len4-1] == zero) len4--; obj = mkvect0(len4); ptr1 = VECTOR(obj); ptr2 = workarr; for(k=0; k0 && w1ptr[len3-1] == zero) len3--; obj = mkvect0(len3); ptr1 = VECTOR(obj); ptr2 = w1ptr; for(k=0; k len1) { return *argptr; } mlen = aribufSize/3 - 6; if(*FLAGPTR(mptr) == fBIGNUM && *BIGLENPTR(mptr) >= mlen) goto ovflexit; if(*mptr == zero) { error(znXmodsym,err_pint,*mptr); return brkerr(); } workarr = arrayStkPtr+1; if(!ARRAYspace(len1 + len2)) { error(znXmodsym,err_memev,voidsym); return brkerr(); } w2ptr = workarr + len1; ptr1 = workarr; ptr2 = VECTORPTR(argptr); for(k=0; k= mlen) goto ovflexit; *ptr1++ = *ptr2++; } ptr1 = w2ptr; ptr2 = VECTORPTR(argptr+1); for(k=0; k= mlen) goto ovflexit; *ptr1++ = *ptr2++; } if(w2ptr[len2-1] != constone) { /* normalize second polynomial */ aa = AriBuf; offsbb = (mlen + 6) & 0xFFFE; bb = AriBuf + offsbb; n = bigretr(w2ptr+len2-1,bb,&signL); m2 = bigref(mptr,&zz,&sign2); m = modinverse(bb,n,zz,m2,aa,AriScratch); if (m==0) { error(znXmodsym, "leading coeff must be invertible mod n",w2ptr[len2-1]); return brkerr(); } obj = mkint(signL,aa,m); WORKpush(obj); for(k=0; k= mlen) goto ovflexit0; if(*mptr == zero) { error(znXgcdsym,err_pint,*mptr); return brkerr(); } arraySavePtr = arrayStkPtr; if(!ARRAYspace(len1 + len2)) { error(znXgcdsym,err_memev,voidsym); return brkerr(); } w1ptr = arraySavePtr + 1; w2ptr = w1ptr + len1; /* store first polynomial */ ptr1 = w1ptr; ptr2 = VECTORPTR(argptr); for(k=0; k= mlen) goto ovflexit; *ptr1++ = *ptr2++; } while((len1 > 0) && (w1ptr[len1-1] == zero)) /* delete leading zeros */ len1--; /* store second polynomial */ ptr1 = w2ptr; ptr2 = VECTORPTR(argptr+1); for(k=0; k= mlen) goto ovflexit; *ptr1++ = *ptr2++; } while((len2 > 0) && (w2ptr[len2-1] == zero)) /* delete leading zeros */ len2--; if((len1==0) && (len2==0)) { arrayStkPtr = arraySavePtr; return mkvect0(0); } else if(len1==0) { ; } else if((len2==0) || (len1 < len2)) { temptr = w1ptr; templen = len1; w1ptr = w2ptr; len1 = len2; w2ptr = temptr; len2 = templen; } while(1) { if(w2ptr[len2-1] != constone) { /* normalize second polynomial */ aa = AriBuf; offsbb = (mlen + 6) & 0xFFFE; bb = AriBuf + offsbb; n = bigretr(w2ptr+len2-1,bb,&signL); m2 = bigref(mptr,&zz,&sign2); m = modinverse(bb,n,zz,m2,aa,AriScratch); if (m==0) { error(znXgcdsym, "module p possibly not prime",*mptr); return brkerr(); } obj = mkint(signL,aa,m); WORKpush(obj); for(k=0; k flen) return flen; aa = AriBuf; mlen = aribufSize/3 - 6; offsbb = (mlen + 6) & 0xFFFE; bb = AriBuf + offsbb; offshilf = (scrbufSize/2) & 0xFFFE; for(k=flen-glen; k>=0; k--) { n = bigretr(FF+glen-1+k,aa,&sign); FF[glen-1+k] = zero; m2 = bigref(mptr,&zz,&sign2); n = modbig(aa,n,zz,m2,AriScratch); if(!n) continue; for(j=0; j<=glen-2; j++) { m = bigref(GG+j,&yy,&sign1); if(!m) continue; m = multbig(aa,n,yy,m,AriScratch,AriScratch+offshilf); sign1 = (sign == sign1 ? MINUSBYTE : 0); /* sign of the negative product */ m1 = bigretr(FF+k+j, bb, &sign2); m = addsarr(bb,m1,sign2,AriScratch,m,sign1,&sign3); obj = mkint(sign3,bb,m); FF[k+j] = obj; } } len = glen - 1; for(k=0; k0 && FF[len-1] == zero) len--; return len; } /*-----------------------------------------------------------------*/ PRIVATE int chkznXmultargs(sym,argptr) truc sym; truc *argptr; { int flg1, flg2; truc *ptr; flg1 = *FLAGPTR(argptr); flg2 = *FLAGPTR(argptr+1); if(flg1 != fVECTOR || flg2 != fVECTOR) { ptr = (flg1 == fVECTOR ? argptr+1 : argptr); return error(sym,err_vect,*ptr); } flg1 = chkintvec(sym,argptr); if(flg1 != aERROR) flg2 = chkintvec(sym,argptr+1); if(flg1 == aERROR || flg2 == aERROR) return aERROR; return (flg1 >= flg2 ? flg1 : flg2); } /*------------------------------------------------------------------*/ #endif /*-----------------------------------------------------------------*/ #ifdef POLYARITH /*-----------------------------------------------------------------*/ PRIVATE truc Fpolmult() { int type; type = chkpolmultargs(polmultsym,argStkPtr-1); if(type == aERROR) return brkerr(); if(type <= fBIGNUM) { return multintpols(argStkPtr-1,MULTFLAG); } else { error(polmultsym,err_imp,voidsym); return mkvect0(0); } } /*------------------------------------------------------------------*/ PRIVATE truc FpolNmult() { int type; type = chkpolmultargs(polNmultsym,argStkPtr-2); if(type == aERROR || chkintnz(polNmultsym,argStkPtr) == aERROR) return brkerr(); return multintpols(argStkPtr-2,MODNFLAG); } /*------------------------------------------------------------------*/ /* ** multiplies two integer polynomials given by argptr[0] and argptr[1] */ PRIVATE truc multintpols(argptr,mode) truc *argptr; int mode; { truc *ptr1, *ptr2; truc *workarr, *w2ptr, *ptr, *wptr; struct vector *vecptr; truc obj; word2 *x, *y, *zz, *aa, *hilf; int len, len1, len2, k, i, j0, j1; int n1, n2, n3, n, m, sign, sign1, sign2, sign3; unsigned mlen, offshilf; len = *VECLENPTR(argptr); len2 = *VECLENPTR(argptr+1); if(len >= len2) { len1 = len; ptr1 = argptr; ptr2 = argptr + 1; } else { len1 = len2; len2 = len; ptr1 = argptr + 1; ptr2 = argptr; } /* now len1 >= len2, lenk = length of vector *ptrk */ if(len2 == 0) return mkvect0(0); /* now len2 >= 1 */ workarr = arrayStkPtr+1; if(!ARRAYspace(len1 + len2)) { error(polmultsym,err_memev,voidsym); return brkerr(); } mlen = aribufSize/3 - 6; ptr = VECTORPTR(ptr1); wptr = workarr; for(i=0; i= mlen) goto ovflexit; *wptr++ = *ptr++; } ptr = VECTORPTR(ptr2); wptr = w2ptr = workarr + len1; for(k=0; k= mlen) goto ovflexit; *wptr++ = *ptr++; } len = len1 + len2 - 1; obj = mkvect0(len); WORKpush(obj); if(mode & MODNFLAG) { zz = AriBuf; n3 = bigretr(argStkPtr,zz,&sign3); if(n3 >= mlen) goto ovflexit; } aa = AriBuf + ((mlen + 6) & 0xFFFE); offshilf = (scrbufSize/2) & 0xFFFE; for(k=0; kele0) + len - 1; while(len > 0 && *ptr-- == zero) len--; vecptr->len = len; obj = WORKretr(); arrayStkPtr = workarr-1; return obj; ovflexit: arrayStkPtr = workarr-1; error(polmultsym,err_ovfl,voidsym); return(brkerr()); } /*------------------------------------------------------------------*/ PRIVATE truc Fpolmod() { int type; type = chkpoldivargs(polmodsym,argStkPtr-1); if(type == aERROR) return brkerr(); return modintpols(argStkPtr-1,MODFLAG); } /*------------------------------------------------------------------*/ PRIVATE truc FpolNmod() { int type; type = chkpoldivargs(polNmodsym,argStkPtr-2); if(type == aERROR) return brkerr(); return modintpols(argStkPtr-2, MODFLAG | MODNFLAG); } /*------------------------------------------------------------------*/ PRIVATE truc Fpoldiv() { int type; type = chkpoldivargs(poldivsym,argStkPtr-1); if(type == aERROR) return brkerr(); return modintpols(argStkPtr-1,DIVFLAG); } /*------------------------------------------------------------------*/ PRIVATE truc FpolNdiv() { int type; type = chkpoldivargs(polNdivsym,argStkPtr-2); if(type == aERROR) return brkerr(); return modintpols(argStkPtr-2, DIVFLAG | MODNFLAG); } /*------------------------------------------------------------------*/ PRIVATE truc modintpols(argptr,mode) truc *argptr; int mode; { truc *workarr, *w1ptr, *w2ptr, *ptr1, *ptr2; truc obj; word2 *yy, *zz, *aa, *bb, *hilf; unsigned mlen, offsbb, offshilf; int sign, sign1, sign2, sign3; int j, k, m, m1, m2, n, len1, len2, len3; int mode1; len1 = *VECLENPTR(argptr); len2 = *VECLENPTR(argptr+1); if(!len2) { error(polmodsym,err_div,voidsym); return brkerr(); } ptr2 = VECTORPTR(argptr+1); if(ptr2[len2-1] != constone) { error(polmodsym,"divisor must have leading coeff = 1",ptr2[len2-1]); return brkerr(); } if(len2 > len1) return(*argptr); else if(len2 == 1) return mkvect0(0); workarr = arrayStkPtr+1; if(!ARRAYspace(len1 + len2)) { error(polmodsym,err_memev,voidsym); return brkerr(); } mlen = aribufSize/3 - 6; offsbb = (mlen + 6) & 0xFFFE; offshilf = (scrbufSize/2) & 0xFFFE; w2ptr = workarr + len1; ptr1 = workarr; ptr2 = VECTORPTR(argptr); for(k=0; k= mlen) goto ovflexit; *ptr1++ = *ptr2++; } ptr1 = w2ptr; ptr2 = VECTORPTR(argptr+1); for(k=0; k= mlen) goto ovflexit; *ptr1++ = *ptr2++; } aa = AriBuf; bb = AriBuf + offsbb; len3 = len1 - len2; for(k=len3; k>=0; k--) { n = bigretr(workarr+len2+k-1,aa,&sign); if(mode & MODNFLAG) { m2 = bigref(argStkPtr,&zz,&sign2); n = modbig(aa,n,zz,m2,AriScratch); if(n && (sign != sign2)) { n = sub1arr(aa,n,zz,m2); sign = sign2; } } if(!n) continue; for(j=0; j<=len2-2; j++) { hilf = AriScratch + offshilf; m = bigref(w2ptr+j,&yy,&sign1); if(!m) continue; m = multbig(aa,n,yy,m,AriScratch,hilf); sign1 = (sign == sign1 ? MINUSBYTE : 0); /* sign of the negative product */ m1 = bigretr(workarr+k+j,bb,&sign2); m = addsarr(bb,m1,sign2,AriScratch,m,sign1,&sign3); obj = mkint(sign3,bb,m); workarr[k+j] = obj; } } mode1 = (mode & DDIVFLAG); if(mode1 == MODFLAG) { if(mode & MODNFLAG) { for(k=0; k<=len2-1; k++) { n = bigretr(workarr+k,aa,&sign); m2 = bigref(argStkPtr,&zz,&sign2); n = modbig(aa,n,zz,m2,AriScratch); if(n && (sign != sign2)) { n = sub1arr(aa,n,zz,m2); sign = sign2; } obj = mkint(sign,aa,n); workarr[k] = obj; } } k = len2-2; while(k >= 0 && workarr[k] == zero) { k--; len2--; } obj = mkvect0(len2-1); ptr1 = VECTOR(obj); ptr2 = workarr; for(k=0; k<=len2-2; k++) *ptr1++ = *ptr2++; } else if(mode1 == DIVFLAG) { w1ptr = workarr + len2 - 1; if(mode & MODNFLAG) { for(k=0; k<=len3; k++) { n = bigretr(w1ptr+k,aa,&sign); m2 = bigref(argStkPtr,&zz,&sign2); n = modbig(aa,n,zz,m2,AriScratch); if(n && (sign != sign2)) { n = sub1arr(aa,n,zz,m2); sign = sign2; } obj = mkint(sign,aa,n); w1ptr[k] = obj; } } while(len3>=0 && w1ptr[len3] == zero) len3--; obj = mkvect0(len3+1); ptr1 = VECTOR(obj); ptr2 = w1ptr; for(k=0; k<=len3; k++) *ptr1++ = *ptr2++; } arrayStkPtr = workarr-1; return obj; ovflexit: arrayStkPtr = workarr-1; error(polmodsym,err_ovfl,voidsym); return(brkerr()); } /*------------------------------------------------------------------*/ PRIVATE int chkpolmultargs(sym,argptr) truc sym; truc *argptr; { int flg1, flg2; truc *ptr; flg1 = *FLAGPTR(argptr); flg2 = *FLAGPTR(argptr+1); if(flg1 != fVECTOR || flg2 != fVECTOR) { ptr = (flg1 == fVECTOR ? argptr+1 : argptr); return error(sym,err_vect,*ptr); } if(sym == polmultsym) { flg1 = chknumvec(sym,argptr); if(flg1 != aERROR) flg2 = chknumvec(sym,argptr+1); } else { flg1 = chkintvec(sym,argptr); if(flg1 != aERROR) flg2 = chkintvec(sym,argptr+1); } if(flg1 == aERROR || flg2 == aERROR) return aERROR; return (flg1 >= flg2 ? flg1 : flg2); } /*------------------------------------------------------------------*/ PRIVATE int chkpoldivargs(sym,argptr) truc sym; truc *argptr; { int flg1, flg2; truc *ptr; flg1 = *FLAGPTR(argptr); flg2 = *FLAGPTR(argptr+1); if(flg1 != fVECTOR || flg2 != fVECTOR) { ptr = (flg1 == fVECTOR ? argptr+1 : argptr); return error(sym,err_vect,*ptr); } flg1 = chkintvec(sym,argptr); if(flg1 != aERROR) flg2 = chkintvec(sym,argptr+1); if(flg1 == aERROR || flg2 == aERROR) return aERROR; return (flg1 >= flg2 ? flg1 : flg2); } /*------------------------------------------------------------------*/ #endif /*******************************************************************/ typedef struct { int mode; unsigned deg; word2 ftail; } GF2n_Field; static GF2n_Field gf2nField = {1, 8, 0x1B}; static int MaxGf2n = 4099; /*-------------------------------------------------------------*/ /* ** if k = sum(b_i * 2**i), then ** spreadbyte[k] = sum(b_i * 4**i). */ static word2 spreadbyte[256] = { 0x0000, 0x0001, 0x0004, 0x0005, 0x0010, 0x0011, 0x0014, 0x0015, 0x0040, 0x0041, 0x0044, 0x0045, 0x0050, 0x0051, 0x0054, 0x0055, 0x0100, 0x0101, 0x0104, 0x0105, 0x0110, 0x0111, 0x0114, 0x0115, 0x0140, 0x0141, 0x0144, 0x0145, 0x0150, 0x0151, 0x0154, 0x0155, 0x0400, 0x0401, 0x0404, 0x0405, 0x0410, 0x0411, 0x0414, 0x0415, 0x0440, 0x0441, 0x0444, 0x0445, 0x0450, 0x0451, 0x0454, 0x0455, 0x0500, 0x0501, 0x0504, 0x0505, 0x0510, 0x0511, 0x0514, 0x0515, 0x0540, 0x0541, 0x0544, 0x0545, 0x0550, 0x0551, 0x0554, 0x0555, 0x1000, 0x1001, 0x1004, 0x1005, 0x1010, 0x1011, 0x1014, 0x1015, 0x1040, 0x1041, 0x1044, 0x1045, 0x1050, 0x1051, 0x1054, 0x1055, 0x1100, 0x1101, 0x1104, 0x1105, 0x1110, 0x1111, 0x1114, 0x1115, 0x1140, 0x1141, 0x1144, 0x1145, 0x1150, 0x1151, 0x1154, 0x1155, 0x1400, 0x1401, 0x1404, 0x1405, 0x1410, 0x1411, 0x1414, 0x1415, 0x1440, 0x1441, 0x1444, 0x1445, 0x1450, 0x1451, 0x1454, 0x1455, 0x1500, 0x1501, 0x1504, 0x1505, 0x1510, 0x1511, 0x1514, 0x1515, 0x1540, 0x1541, 0x1544, 0x1545, 0x1550, 0x1551, 0x1554, 0x1555, 0x4000, 0x4001, 0x4004, 0x4005, 0x4010, 0x4011, 0x4014, 0x4015, 0x4040, 0x4041, 0x4044, 0x4045, 0x4050, 0x4051, 0x4054, 0x4055, 0x4100, 0x4101, 0x4104, 0x4105, 0x4110, 0x4111, 0x4114, 0x4115, 0x4140, 0x4141, 0x4144, 0x4145, 0x4150, 0x4151, 0x4154, 0x4155, 0x4400, 0x4401, 0x4404, 0x4405, 0x4410, 0x4411, 0x4414, 0x4415, 0x4440, 0x4441, 0x4444, 0x4445, 0x4450, 0x4451, 0x4454, 0x4455, 0x4500, 0x4501, 0x4504, 0x4505, 0x4510, 0x4511, 0x4514, 0x4515, 0x4540, 0x4541, 0x4544, 0x4545, 0x4550, 0x4551, 0x4554, 0x4555, 0x5000, 0x5001, 0x5004, 0x5005, 0x5010, 0x5011, 0x5014, 0x5015, 0x5040, 0x5041, 0x5044, 0x5045, 0x5050, 0x5051, 0x5054, 0x5055, 0x5100, 0x5101, 0x5104, 0x5105, 0x5110, 0x5111, 0x5114, 0x5115, 0x5140, 0x5141, 0x5144, 0x5145, 0x5150, 0x5151, 0x5154, 0x5155, 0x5400, 0x5401, 0x5404, 0x5405, 0x5410, 0x5411, 0x5414, 0x5415, 0x5440, 0x5441, 0x5444, 0x5445, 0x5450, 0x5451, 0x5454, 0x5455, 0x5500, 0x5501, 0x5504, 0x5505, 0x5510, 0x5511, 0x5514, 0x5515, 0x5540, 0x5541, 0x5544, 0x5545, 0x5550, 0x5551, 0x5554, 0x5555}; /*-------------------------------------------------------------------*/ /* ** Adds two gf2n_int's in ptr[0] and ptr[1] */ PUBLIC truc addgf2ns(ptr) truc *ptr; { word2 *y; int n, m, deg; int sign; n = bigretr(ptr,AriBuf,&sign); m = bigref(ptr+1,&y,&sign); deg = gf2nField.deg; if(deg < bit_length(AriBuf,n) || deg < bit_length(y,m)) { error(plussym,"gf2nint summand too big",voidsym); return brkerr(); } n = xorbitvec(AriBuf,n,y,m); return(mkgf2n(AriBuf,n)); } /*-------------------------------------------------------------------*/ /* ** Multiplies two gf2n_int's in ptr[0] and ptr[1] */ PUBLIC truc multgf2ns(ptr) truc *ptr; { int n, m, sign, deg; word2 *x, *y; n = bigref(ptr,&x,&sign); m = bigref(ptr+1,&y,&sign); deg = gf2nField.deg; if(deg < bit_length(x,n) || deg < bit_length(y,m)) { error(timessym,"gf2nint factor too big",voidsym); return brkerr(); } n = gf2polmult(x,n,y,m,AriBuf); n = gf2nmod(AriBuf,n); return mkgf2n(AriBuf,n); } /*-------------------------------------------------------------------*/ /* ** Divide gf2nint ptr[0] by gf2nint ptr[1] */ PUBLIC truc divgf2ns(ptr) truc *ptr; { word2 *x, *y, *z; int n, m, sign, deg; n = bigref(ptr,&x,&sign); deg = gf2nField.deg; if(deg < bit_length(x,n)) { error(divfsym,"gf2nint argument too big",*ptr); return brkerr(); } y = AriBuf; m = bigretr(ptr+1,y,&sign); if(deg < bit_length(y,m)) { error(divfsym,"gf2nint argument too big",ptr[1]); return brkerr(); } z = y + m + 1; m = gf2ninverse(y,m,z,AriScratch); if(m == 0) { error(divfsym,err_div,voidsym); return brkerr(); } n = gf2polmult(z,m,x,n,AriScratch); cpyarr(AriScratch,n,AriBuf); n = gf2nmod(AriBuf,n); return mkgf2n(AriBuf,n); } /*-------------------------------------------------------------------*/ /* ** gf2nint in ptr[0] is raised to power ptr[1], which may ** be a positive or negative integer */ PUBLIC truc exptgf2n(ptr) truc *ptr; { word2 *x, *y, *z; int n, m, N, deg, sign; n = bigref(ptr,&x,&sign); deg = gf2nField.deg; if(deg < bit_length(x,n)) { error(powersym,"gf2nint argument too big",*ptr); return brkerr(); } m = bigref(ptr+1,&y,&sign); if(sign) { cpyarr(x,n,AriBuf); x = AriBuf; z = AriBuf + n + 1; n = gf2ninverse(AriBuf,n,z,AriScratch); if(n == 0) { error(powersym,err_div,voidsym); return brkerr(); } else { cpyarr(z,n,x); z = AriBuf + n + 1; } if(m == 1 && y[0] == 1) { return mkgf2n(x,n); } } else if(m == 0) { return gf2none; } else { z = AriBuf; } N = gf2npower(x,n,y,m,z,AriScratch); return mkgf2n(z,N); } /*-------------------------------------------------------------------*/ /* ** Transforms object in *argStkPtr to data type gf2nint */ PRIVATE truc Fgf2nint() { word2 *x; byte *bpt; unsigned u; unsigned len; int i, n, flg, sign; flg = *FLAGPTR(argStkPtr); if(flg == fFIXNUM || flg == fBIGNUM || flg == fGF2NINT) { n = bigretr(argStkPtr,AriBuf,&sign); } else if(flg == fBYTESTRING) { len = *STRLENPTR(argStkPtr); if(len >= aribufSize*2 - 2) { error(gf2n_sym,err_2long,mkfixnum(len)); return(brkerr()); } bpt = (byte *)STRINGPTR(argStkPtr); n = len / 2; x = AriBuf; for(i=0; i= 2 expected",*argStkPtr); return brkerr(); } else if(n > MaxGf2n) { error(gf2ninisym,"maximal degree is",mkfixnum(MaxGf2n)); return brkerr(); } u = gf2polfindirr(n); if(!u) { error(gf2ninisym, "no irreducible polynomial found", voidsym); return brkerr(); } gf2nField.deg = n; gf2nField.ftail = u; m = n/16 + 1; x = AriBuf; setarr(x,m,0); x[0] = u; setbit(x,n); return mkint(0,x,m); } /*-------------------------------------------------------------------*/ PRIVATE truc Fgf2ndegree() { unsigned deg = gf2nField.deg; return mkfixnum(deg); } /*-------------------------------------------------------------------*/ PRIVATE truc Fgf2nfieldpol() { int n; unsigned deg; word2 *x; deg = gf2nField.deg; n = (deg+1)/16 + 1; x = AriBuf; setarr(x,n,0); x[0] = gf2nField.ftail; setbit(x,deg); return mkint(0,x,n); } /*-------------------------------------------------------------------*/ #if 0 PRIVATE truc Fgf2nparms() { int mode, n; unsigned deg; word2 *x; truc fdeg, fpol, vec; truc *ptr; mode = gf2nField.mode; deg = gf2nField.deg; if(mode == 1) { n = (deg+1)/16 + 1; x = AriBuf; setarr(x,n,0); x[0] = gf2nField.ftail; setbit(x,deg); fpol = mkint(0,x,n); WORKpush(fpol); fdeg = mkfixnum(deg); vec = mkvect0(2); ptr = VECTOR(vec); ptr[0] = fdeg; ptr[1] = WORKretr(); return vec; } else { error(gf2parmsym,err_imp,voidsym); return brkerr(); } } #endif /*-------------------------------------------------------------------*/ PRIVATE truc Fmaxgf2n() { return mkfixnum(MaxGf2n); } /*-------------------------------------------------------------------*/ PRIVATE truc Fgf2ntrace() { int n, t, sign; word2 *x; if(*FLAGPTR(argStkPtr) != fGF2NINT) { error(gf2ntrsym,"gfnint expected",*argStkPtr); return brkerr(); } x = AriBuf; n = bigretr(argStkPtr,x,&sign); if(n == aERROR) return brkerr(); if(gf2nField.deg < bit_length(x,n)) { error(gf2ntrsym,"gf2nint argument too big",voidsym); return brkerr(); } t = gf2ntrace(x,n); return mkfixnum(t); } /*------------------------------------------------------------------*/ PRIVATE truc Fgf2Xmult() { int n,m,len,sign; word2 *x, *y; n = bigref(argStkPtr-1,&x,&sign); if (n == aERROR) goto errexit; m = bigref(argStkPtr,&y,&sign); if (m == aERROR) goto errexit; if(n + m >= aribufSize) { error(gf2Xmulsym,err_ovfl,voidsym); return(brkerr()); } else if(!n || !m) return(zero); len = gf2polmult(x,n,y,m,AriBuf); return mkint(0,AriBuf,len); errexit: error(gf2Xmulsym,err_intt,voidsym); return brkerr(); } /*------------------------------------------------------------------*/ PRIVATE truc Fgf2Xsquare() { int n,len,sign; word2 *x; n = bigref(argStkPtr,&x,&sign); if (n == aERROR) { error(gf2Xsqsym,err_intt,voidsym); return brkerr(); } if (2*n >= aribufSize) { error(gf2Xmulsym,err_ovfl,voidsym); return(brkerr()); } else if (!n) return zero; len = gf2polsquare(x,n,AriBuf); return mkint(0,AriBuf,len); } /*------------------------------------------------------------------*/ PRIVATE truc Fgf2Xdivide() { int n,m,len,sign,rlen; word2 *x, *y; truc obj, vec; truc *vptr; x = AriScratch; n = bigretr(argStkPtr-1,x,&sign); if (n == aERROR) goto errexit; else if(n >= aribufSize) { error(gf2Xddivsym,err_ovfl,voidsym); return(brkerr()); } m = bigref(argStkPtr,&y,&sign); if (m == aERROR) goto errexit; else if(m == 0) { error(gf2Xddivsym,err_div,voidsym); return brkerr(); } len = gf2poldivide(x,n,y,m,AriBuf,&rlen); y = AriBuf + len; cpyarr(x,rlen,y); obj = mkint(0,AriBuf,len); WORKpush(obj); obj = mkint(0,y,rlen); WORKpush(obj); vec = mkvect0(2); vptr = VECTOR(vec); vptr[1] = WORKretr(); vptr[0] = WORKretr(); return vec; errexit: error(gf2Xddivsym,err_intt,voidsym); return brkerr(); } /*------------------------------------------------------------------*/ PRIVATE truc Fgf2Xdiv() { int n,m,len,sign; word2 *x, *y; x = AriScratch; n = bigretr(argStkPtr-1,x,&sign); if (n == aERROR) goto errexit; m = bigref(argStkPtr,&y,&sign); if (m == aERROR) goto errexit; if (m > n) return zero; else if(n >= aribufSize) { error(gf2Xdivsym,err_ovfl,voidsym); return(brkerr()); } else if(!m) { error(gf2Xdivsym,err_div,voidsym); return brkerr(); } len = gf2poldiv(x,n,y,m,AriBuf); return mkint(0,AriBuf,len); errexit: error(gf2Xdivsym,err_intt,voidsym); return brkerr(); } /*------------------------------------------------------------------*/ PRIVATE truc Fgf2Xmod() { int n,m,len,sign; word2 *x, *y; x = AriBuf; n = bigretr(argStkPtr-1,x,&sign); if (n == aERROR) goto errexit; m = bigref(argStkPtr,&y,&sign); if (m == aERROR) goto errexit; if(n >= aribufSize) { error(gf2Xmodsym,err_ovfl,voidsym); return(brkerr()); } else if(!m) { error(gf2Xmodsym,err_div,voidsym); return brkerr(); } len = gf2polmod(x,n,y,m); return mkint(0,AriBuf,len); errexit: error(gf2Xmodsym,err_intt,voidsym); return brkerr(); } /*------------------------------------------------------------------*/ PRIVATE truc Fgf2Xgcd() { int n,m,len,sign; word2 *x, *y; x = AriBuf; y = AriScratch; n = bigretr(argStkPtr-1,x,&sign); if (n == aERROR) goto errexit; m = bigretr(argStkPtr,y,&sign); if (m == aERROR) goto errexit; len = gf2polgcd(x,n,y,m); return mkint(0,AriBuf,len); errexit: error(gf2Xgcdsym,err_intt,voidsym); return brkerr(); } /*------------------------------------------------------------------*/ PRIVATE truc Fgf2Xmodpow() { word2 *x, *y, *f; int n,m,flen,len,sign; int flg; truc symb; n = bigref(argStkPtr-2,&x,&sign); if (n == aERROR) { symb = argStkPtr[-2]; goto errexit; } flg = *FLAGPTR(argStkPtr-1); if (flg != fFIXNUM && flg != fBIGNUM) { error(gf2Xmpowsym,err_int,argStkPtr[-1]); return brkerr(); } flen = bigref(argStkPtr,&f,&sign); if (flen == aERROR) { symb = argStkPtr[0]; goto errexit; } else if (flen >= aribufSize/2 - 1) { error(gf2Xmpowsym,err_ovfl,argStkPtr[0]); return brkerr(); } m = bigref(argStkPtr-1,&y,&sign); if (m == aERROR) { symb = argStkPtr[-1]; goto errexit; } else if (sign) { /******************************/ /* TODO: negative exponent */ error(gf2Xmpowsym,err_p0int,argStkPtr[-1]); return brkerr(); } len = gf2polmodpow(x,n,y,m,f,flen,AriBuf,AriScratch); return mkint(0,AriBuf,len); errexit: error(gf2Xmpowsym,err_intt,symb); return brkerr(); } /*------------------------------------------------------------------*/ /* ** P := (x,n) and Q := (y,m) are considered as polynomials over GF(2) ** Calculates P mod Q; works destructively on x; returns new length */ PRIVATE int gf2polmod(x,n,y,m) word2 *x, *y; int n,m; { int N, M, k, s; if(m == 0) return n; N = bit_length(x,n) - 1; M = bit_length(y,m) - 1; if(M > N) return n; for(k=N; k>=M; --k) { if(testbit(x,k)) { s = k-M; n = bitxorshift(x,n,y,m,s); } } return n; } /*------------------------------------------------------------------*/ /* ** P := (x,n) and Q := (y,m) are considered as polynomials over GF(2) ** Calculates P div Q; works destructively on x; ** Result returned in z; return value=zlen */ PRIVATE int gf2poldiv(x,n,y,m,z) word2 *x, *y, *z; int n,m; { int N, M, k, s, zlen; if(m == 0) return n; N = bit_length(x,n) - 1; M = bit_length(y,m) - 1; if(M > N) return 0; zlen = (N - M)/16 + 1; setarr(z,zlen,0); for(k=N; k>=M; --k) { if(testbit(x,k)) { s = k-M; n = bitxorshift(x,n,y,m,s); setbit(z,s); } } return zlen; } /*------------------------------------------------------------------*/ /* ** P := (x,n) and Q := (y,m) are considered as polynomials over GF(2) ** Calculates P div Q; works destructively on x; ** Quotient returned in z; return value=zlen ** x becomes rest, ist len is returned in *rlentpr */ PRIVATE int gf2poldivide(x,n,y,m,z,rlenptr) word2 *x, *y, *z; int n,m; int *rlenptr; { int N, M, k, s, zlen; if(m == 0) { /* division by zero */ *rlenptr = n; return 0; } N = bit_length(x,n) - 1; M = bit_length(y,m) - 1; if(M > N) { *rlenptr = n; return 0; } zlen = (N - M)/16 + 1; setarr(z,zlen,0); for(k=N; k>=M; --k) { if(testbit(x,k)) { s = k-M; n = bitxorshift(x,n,y,m,s); setbit(z,s); } } *rlenptr = n; return zlen; } /*------------------------------------------------------------------*/ PRIVATE int gf2ntrace(x,n) word2 *x; int n; { int deg = gf2nField.deg; unsigned ftail = gf2nField.ftail; int k, m, t; m = (deg/16) + 1; for(k=n; k m) n = m; if(testbit(x,deg)) x[0] ^= ftail; if(testbit(x,k)) t++; } return (t & 1); } /*------------------------------------------------------------------*/ /* ** Shift (x,n) to the left by 1 bit ** Works destructively on x */ PRIVATE int shiftleft1(x,n) word2 *x; int n; { int k, ovfl; unsigned maskhi = 0x8000, u = 1; if(n == 0) return n; ovfl = (x[n-1] & maskhi); for(k=n-1; k>=1; k--) { x[k] <<= 1; if(x[k-1] & maskhi) x[k] |= u; } x[0] <<= 1; if(ovfl) { x[n] = u; n++; } return n; } /*------------------------------------------------------------------*/ /* ** (y,m) is shifted by s >= 0 and xored with (x,n) ** If bitlength of (x,n) < bitlength of (y,m) plus s, ** higher entries of x must be 0. */ PRIVATE int bitxorshift(x,n,y,m,s) word2 *x, *y; int n,m,s; { int s0, s1, t1, k, k1; unsigned u; if(!m) return n; s0 = (s >> 4); s1 = (s & 0xF); if(s1 == 0) { for(k=0, k1=s0-1; k> t1)); } u = (y[m-1] >> t1); if(u) { x[++k1] ^= u; } } if(k1 >= n) n = k1+1; while((n > 0) && (x[n-1] == 0)) n--; return n; } /*------------------------------------------------------------------*/ /* ** Reduce (x,n) modulo the field polynomial given in gf2nField ** Works destructively on (x,n) */ PRIVATE int gf2nmod(x,n) word2 *x; int n; { int N, m, s, s0, s1; int deg = gf2nField.deg; unsigned ftail = gf2nField.ftail; unsigned mask = 0xFFFF; unsigned t1, t2; N = bit_length(x,n) - 1; if(N < deg) return n; m = (deg >> 4); mask >>= (16 - (deg & 0xF)); for(s = N-deg; s >= 0; s--) { if(testbit(x,deg+s)) { s0 = (s >> 4); s1 = (s & 0xF); t1 = (ftail << s1); x[s0] ^= t1; if(s1 && (t2 = (ftail >> (16-s1)))) x[s0+1] ^= t2; } } x[m] &= mask; while(m >= 0 && (x[m] == 0)) m--; return m+1; } /*------------------------------------------------------------------*/ /* ** Multiplies gf2pols (x,n) and (y,m); ** does not alter (x,n) or (y,m) ** Result returned in z */ PRIVATE int gf2polmult(x,n,y,m,z) word2 *x, *y, *z; int n,m; { int k, M, n1; M = bit_length(y,m) - 1; if(M < 0) return 0; cpyarr(x,n,z); n1 = shiftarr(z,n,M); for(k=M-1; k>=0; k--) { if(testbit(y,k)) { n1 = bitxorshift(z,n1,x,n,k); } } return n1; } /*------------------------------------------------------------------*/ /* ** Squares the gf2pol (x,n) ** Result returned in z */ PRIVATE int gf2polsquare(x,n,z) word2 *x, *z; int n; { int k, N; unsigned u; if(n == 0) return 0; N = 0; for(k=0; k> 8) & 0x00FF]; N++; } u = x[n-1]; z[N] = spreadbyte[u & 0x00FF]; N++; u = (u >> 8) & 0x00FF; if(u) { z[N] = spreadbyte[u]; N++; } return N; } /*-------------------------------------------------------------------*/ /* ** Calculates inverse of (x,n). ** Result in z; if (x,n) is not invertible, 0 is returned ** uu is an auxiliary array needed for intermediate calculations */ PRIVATE int gf2ninverse(x,n,z,uu) word2 *x, *z, *uu; int n; { int deg, m, zlen; word2 *y; y = uu; deg = gf2nField.deg; m = (deg+1)/16 + 1; setarr(y,m,0); y[0] = gf2nField.ftail; setbit(y,deg); uu = y + m + 1; n = gf2polgcdx(x,n,y,m,z,&zlen,uu); if(x[0] != 1 || n != 1) { return 0; } return zlen; } /*------------------------------------------------------------------*/ /* ** gf2nint (x,n) is raised to power (y,n) ** Result in z; hilf is an auxiliary array */ PRIVATE int gf2npower(x,n,y,m,z,hilf) word2 *x,*y,*z,*hilf; int n, m; { int N, k, exlen; if(m == 0) { z[0] = 1; return 1; } else if(n == 0) return 0; exlen = bit_length(y,m); cpyarr(x,n,z); N = n; for(k=exlen-2; k>=0; k--) { cpyarr(z,N,hilf); N = gf2polsquare(hilf,N,z); N = gf2nmod(z,N); if(testbit(y,k)) { cpyarr(z,N,hilf); N = gf2polmult(hilf,N,x,n,z); N = gf2nmod(z,N); } } return N; } /*------------------------------------------------------------------*/ /* ** gf2pol (x,n) is raised to power (y,n) modulo (f,flen) ** Result in z; hilf is an auxiliary array ** (x,n), (y,m) and (f,flen) are not altered */ PRIVATE int gf2polmodpow(x,n,y,m,f,flen,z,hilf) word2 *x,*y,*z,*f,*hilf; int n, m, flen; { int N, k, exlen; if(m == 0) { z[0] = 1; return 1; } else if(n == 0) return 0; exlen = bit_length(y,m); cpyarr(x,n,z); N = n; for(k=exlen-2; k>=0; k--) { cpyarr(z,N,hilf); N = gf2polsquare(hilf,N,z); N = gf2polmod(z,N,f,flen); if(testbit(y,k)) { cpyarr(z,N,hilf); N = gf2polmult(hilf,N,x,n,z); N = gf2polmod(z,N,f,flen); } } return N; } /*------------------------------------------------------------------*/ /* ** Calculates greatest common divisor of gf2pols (x,n) and (y,m); ** Works destructively on x and y ** Result is returned in x */ PRIVATE int gf2polgcd(x,n,y,m) word2 *x, *y; int n,m; { while(m > 0) { n = gf2polmod(x,n,y,m); if(n == 0) { cpyarr(y,m,x); n = m; break; } m = gf2polmod(y,m,x,n); } return n; } /*-----------------------------------------------------------------*/ /* ** Calculates the gcd d of (x,n) and (y,m) (considered as polynomials ** over GF(2)) and calculates a coefficient lambda such that ** d = lambda*(x,n) mod (y,m). ** Works destructively on x and y. ** The gcd is stored in x, its length is the return value; ** lambda = (z, *zlenptr) ** uu is an auxiliary array needed for intermediate calculations */ PRIVATE int gf2polgcdx(x,n,y,m,z,zlenptr,uu) word2 *x, *y, *z, *uu; int n,m; int *zlenptr; { int s, N, M, zlen, ulen, nn, m0; word2 *y0; nn = (n >= m ? n : m); setarr(z,nn,0); setarr(uu,nn,0); z[0] = 1; zlen = 1; ulen = 0; m0 = m; y0 = uu + nn + 1; cpyarr(y,m0,y0); N = bit_length(x,n); M = bit_length(y,m); while(M > 0) { /* loop invariants: (x,n) = z*(x0,n0) mod (y0,m0); (y,m) = uu*(x0,n0) mod (y0,m0); where (x0,n0) and (y0,m0) are the initial values of (x,n) and (y,m) */ if(N >= M) { s = N - M; n = bitxorshift(x,n,y,m,s); N = bit_length(x,n); zlen = bitxorshift(z,zlen,uu,ulen,s); if(zlen > m0) zlen = gf2polmod(z,zlen,y0,m0); } else { s = M - N; m = bitxorshift(y,m,x,n,s); M = bit_length(y,m); ulen = bitxorshift(uu,ulen,z,zlen,s); if(ulen > m0) ulen = gf2polmod(uu,ulen,y0,m0); } if(N == 0) { cpyarr(y,m,x); n = m; cpyarr(uu,ulen,z); zlen = ulen; break; } } if(bit_length(z,zlen) >= bit_length(y0,m0)) zlen = gf2polmod(z,zlen,y0,m0); *zlenptr = zlen; return n; } /*-----------------------------------------------------------------*/ PRIVATE truc Fgf2Xprimtest() { int n, sign, res; word2 *x; n = bigref(argStkPtr,&x,&sign); if (n == aERROR) { error(gf2Xprimsym,err_intt,argStkPtr[0]); return brkerr(); } res = gf2polirred1(x,n,AriBuf,AriScratch); return (res ? true : false); } /*-----------------------------------------------------------------*/ /* ** Tests whether the gf2 polynomial given by (x,n) is irreducible. ** yy and zz are auxiliary arrays needed for intermediate calculations */ PRIVATE int gf2polirred1(x,n,yy,zz) word2 *x, *yy, *zz; int n; { int m, m1, N, N0, k, mode; word2 xi; word2 *x2k; if (n == 0) return 0; if ((x[0] & 1) == 0) /* polynomial divisible by X */ return 0; N = bit_length(x,n) - 1; N0 = 5*intsqrt(N); /* somewhat arbitrary */ if (N0 < N/3) { mode = 1; } else { mode = 0; N0 = N/2; } x2k = zz + n + 1; xi = 2; m = 1; x2k[0] = xi; for(k=1; k<=N0; k++) { m = gf2polsquare(x2k,m,yy); m = gf2polmod(yy,m,x,n); if((m == 1 && yy[0] == xi) || m == 0) return 0; cpyarr(yy,m,x2k); yy[0] ^= xi; cpyarr(x,n,zz); m1 = gf2polgcd(yy,m,zz,n); if(m1 != 1 || yy[0] != 1) { return 0; } } if (mode == 0) return 1; for(k=N0+1; k aribufSize in Fstrsplit ** 1997-03-25: Fstrsplit now PRIVATE ** 1997-03-29: changed function bytestraddr ** 1997-04-13: reorg (newintsym) ** 1997-08-01: removed create_array ** 2000-01-02: fixed bug in byteswap() ** 2001-06-17: corrected type in error message ** 2002-03-08: changed direction of sort with user defined sort fcn ** 2002-03-28: functions string_scan, stack2string, stack_arraypush, realloc ** 2002-04-14: function binsearch ** 2002-08-05: small change in GmemBB ** 2003-02-11: mkcopy in Fbstring and Ftextstring ** 2003-06-06: mkcopy in Srecfield, Farrele and Fstkpush ** 2007-07-24: bug fix in Fstkpush ** 2010-03-06: bug fix in Gchangecase ** 2018-09-13 fixed minor errors and compiler warnings ** (thanks to D. Trebbien for testing) */ #include "common.h" #define QUICKSORT PUBLIC truc arraysym, stringsym, charsym, stacksym; PUBLIC truc vectorsym, pairsym; PUBLIC truc mkarrsym, mkstrsym, mkbstrsym; PUBLIC truc nullstring, nullbstring; PUBLIC truc bstringsym, bstr_sym, str_sym; PUBLIC truc ofsym; PUBLIC truc arr_sym, subarrsym; PUBLIC truc recordsym, mkrecsym, rec_sym, pointrsym, derefsym; /**** Prototypen exportierter Funktionen ****/ PUBLIC void iniarray (void); PUBLIC void iniargv (int argc, char *argv[]); PUBLIC int stringsplit (char *str, char *trenn, word2 *offsets); PUBLIC truc arrassign (truc *arr, truc obj); PUBLIC truc subarrassign (truc *arr, truc obj); PUBLIC void sortarr (truc *arr, unsigned len, ifuntt cmpfun); PUBLIC int bytestraddr (truc *ptr, truc **ppbstr, byte **ppch, unsigned *plen); PUBLIC truc fullrecassign (truc *rptr, truc obj); PUBLIC truc recfassign (truc *rptr, truc field, truc obj); PUBLIC truc Pdispose (truc *ptr); /******* Modulglobale Variablen **********/ PRIVATE truc argvsym; PRIVATE truc lengthsym, maxarrsym; PRIVATE truc concatsym, splitsym, toupsym, tolowsym, indexsym, sscansym; PRIVATE truc pushsym, popsym, topsym, resetsym, emptysym; PRIVATE truc stk2arrsym, stk2strsym, arrpushsym; PRIVATE truc chrsym, ordsym; PRIVATE truc sortsym, bsearchsym; PRIVATE truc mbtestsym, mbsetsym, mbclrsym, mshiftsym; PRIVATE truc mandsym, morsym, mxorsym, mnotsym, mbitswsym, mbyteswsym; PRIVATE truc mknewsym, allocsym, reallocsym, vrtrimsym; /******* Prototypen modul-interner Funktionen ******/ PRIVATE truc Flength (void); PRIVATE truc Fchr (void); PRIVATE truc Ford (void); PRIVATE truc Fvector (int argn); PRIVATE truc Fpair (void); PRIVATE truc Fmkarray (int argn); PRIVATE truc Falloc (int argn); PRIVATE truc Srealloc (void); PRIVATE truc Fvectrtrim (void); PRIVATE truc Fmkstring (void); PRIVATE truc mkstring (truc *ptr, int flg, int ch); PRIVATE truc Fmkbstring (void); PRIVATE truc Fconcat (int argn); PRIVATE truc Findex (void); PRIVATE long substrindex (byte *str, size_t len, byte *sub, size_t len1); PRIVATE truc Fstrsplit (int argn); PRIVATE truc Fstrscan (int argn); PRIVATE truc Ftolower (void); PRIVATE truc Ftoupper (void); PRIVATE truc Gchangecase (truc symb); PRIVATE truc Farrele (void); PRIVATE truc Fsubarr (void); PRIVATE int indrange (truc *ptr, long len, long *pn0, long *pn1); PRIVATE int arrindex (truc *ptr, long *pindex); PRIVATE char *stringele (truc *ptr, long index); PRIVATE truc *vectele (truc *ptr, long index); PRIVATE int arrcompat (int flg1, int flg2); PRIVATE long stacklength (truc *ptr); PRIVATE truc Fstkpush (void); PRIVATE truc Fstkarrpush (int argn); PRIVATE truc Fstkpop (void); PRIVATE truc Fstktop (void); PRIVATE truc Gstkretr (truc symb); PRIVATE truc Fstkreset (void); PRIVATE truc Fstkempty (void); PRIVATE truc Fstk2array (void); PRIVATE truc Fstk2string (void); PRIVATE truc Fmaxarray (void); PRIVATE int compfun (truc *ptr1, truc *ptr2); PRIVATE int ucompfun (truc *ptr1, truc *ptr2); PRIVATE truc Ssort (void); PRIVATE truc Hsort1 (truc *argptr); PRIVATE truc Hsort2 (truc *argptr, truc fun); PRIVATE truc Fbsearch (int argn); PRIVATE truc Hbsearch1 (truc *ele, truc *vptr, int flg); PRIVATE int vectaddr (truc *ptr, truc **ppvec, truc **parr, unsigned *plen); PRIVATE truc Ftextstring (void); PRIVATE truc Fbstring (int argn); PRIVATE truc Smembtest (void); PRIVATE truc Smembset (void); PRIVATE truc Smembclear (void); PRIVATE truc Smemshift (void); PRIVATE truc Smemand (void); PRIVATE truc Smemor (void); PRIVATE truc Smemxor (void); PRIVATE truc Smemnot (void); PRIVATE truc Smembitsw (void); PRIVATE truc Smembytesw (void); PRIVATE truc GmemBi (truc symb); PRIVATE truc GmemBB (truc symb); PRIVATE void byteshift (byte *ptr, unsigned len, long sh); PRIVATE void byteswap (byte *ptr, unsigned len, unsigned grp); PRIVATE int Paddr (truc *ptr, trucptr *pvptr); PRIVATE truc Fmkrec0 (void); PRIVATE truc Srecfield (void); PRIVATE truc Sderef (void); PRIVATE truc Snew (void); PRIVATE truc *Ltrucf (int flg, truc *pptr); PRIVATE truc *recfield (truc *rptr, truc field); PRIVATE truc pnew10 (truc *point, int mode); PRIVATE byte BitSwap[256] = { 0x00, 0x80, 0x40, 0xC0, 0x20, 0xA0, 0x60, 0xE0, 0x10, 0x90, 0x50, 0xD0, 0x30, 0xB0, 0x70, 0xF0, 0x08, 0x88, 0x48, 0xC8, 0x28, 0xA8, 0x68, 0xE8, 0x18, 0x98, 0x58, 0xD8, 0x38, 0xB8, 0x78, 0xF8, 0x04, 0x84, 0x44, 0xC4, 0x24, 0xA4, 0x64, 0xE4, 0x14, 0x94, 0x54, 0xD4, 0x34, 0xB4, 0x74, 0xF4, 0x0C, 0x8C, 0x4C, 0xCC, 0x2C, 0xAC, 0x6C, 0xEC, 0x1C, 0x9C, 0x5C, 0xDC, 0x3C, 0xBC, 0x7C, 0xFC, 0x02, 0x82, 0x42, 0xC2, 0x22, 0xA2, 0x62, 0xE2, 0x12, 0x92, 0x52, 0xD2, 0x32, 0xB2, 0x72, 0xF2, 0x0A, 0x8A, 0x4A, 0xCA, 0x2A, 0xAA, 0x6A, 0xEA, 0x1A, 0x9A, 0x5A, 0xDA, 0x3A, 0xBA, 0x7A, 0xFA, 0x06, 0x86, 0x46, 0xC6, 0x26, 0xA6, 0x66, 0xE6, 0x16, 0x96, 0x56, 0xD6, 0x36, 0xB6, 0x76, 0xF6, 0x0E, 0x8E, 0x4E, 0xCE, 0x2E, 0xAE, 0x6E, 0xEE, 0x1E, 0x9E, 0x5E, 0xDE, 0x3E, 0xBE, 0x7E, 0xFE, 0x01, 0x81, 0x41, 0xC1, 0x21, 0xA1, 0x61, 0xE1, 0x11, 0x91, 0x51, 0xD1, 0x31, 0xB1, 0x71, 0xF1, 0x09, 0x89, 0x49, 0xC9, 0x29, 0xA9, 0x69, 0xE9, 0x19, 0x99, 0x59, 0xD9, 0x39, 0xB9, 0x79, 0xF9, 0x05, 0x85, 0x45, 0xC5, 0x25, 0xA5, 0x65, 0xE5, 0x15, 0x95, 0x55, 0xD5, 0x35, 0xB5, 0x75, 0xF5, 0x0D, 0x8D, 0x4D, 0xCD, 0x2D, 0xAD, 0x6D, 0xED, 0x1D, 0x9D, 0x5D, 0xDD, 0x3D, 0xBD, 0x7D, 0xFD, 0x03, 0x83, 0x43, 0xC3, 0x23, 0xA3, 0x63, 0xE3, 0x13, 0x93, 0x53, 0xD3, 0x33, 0xB3, 0x73, 0xF3, 0x0B, 0x8B, 0x4B, 0xCB, 0x2B, 0xAB, 0x6B, 0xEB, 0x1B, 0x9B, 0x5B, 0xDB, 0x3B, 0xBB, 0x7B, 0xFB, 0x07, 0x87, 0x47, 0xC7, 0x27, 0xA7, 0x67, 0xE7, 0x17, 0x97, 0x57, 0xD7, 0x37, 0xB7, 0x77, 0xF7, 0x0F, 0x8F, 0x4F, 0xCF, 0x2F, 0xAF, 0x6F, 0xEF, 0x1F, 0x9F, 0x5F, 0xDF, 0x3F, 0xBF, 0x7F, 0xFF }; /*--------------------------------------------------------------------*/ PUBLIC void iniarray() { truc temp; arr_sym = newintsym("array[ ]", sFBINARY, (wtruc)Farrele); subarrsym = newintsym("array[..]",sFBINARY, (wtruc)Fsubarr); lengthsym = newsymsig("length", sFBINARY, (wtruc)Flength, s_1); chrsym = newsymsig("chr", sFBINARY, (wtruc)Fchr, s_1); ordsym = newsymsig("ord", sFBINARY, (wtruc)Ford, s_1); sortsym = newsymsig("sort", sSBINARY, (wtruc)Ssort, s_12); bsearchsym= newsymsig("binsearch", sFBINARY, (wtruc)Fbsearch, s_23); concatsym = newsymsig("concat", sFBINARY, (wtruc)Fconcat, s_1u); splitsym = newsymsig("string_split",sFBINARY,(wtruc)Fstrsplit,s_12); sscansym = newsymsig("string_scan", sFBINARY,(wtruc)Fstrscan, s_23); toupsym = newsymsig("toupper",sFBINARY, (wtruc)Ftoupper,s_1); tolowsym = newsymsig("tolower",sFBINARY, (wtruc)Ftolower,s_1); indexsym = newsymsig("substr_index",sFBINARY,(wtruc)Findex,s_2); arraysym = newsym("array", sTYPESPEC, nullsym); ofsym = newsym("of", sPARSAUX, nullsym); recordsym = newsym("record", sTYPESPEC, nullsym); mkrecsym = newintsym("record", sFBINARY, (wtruc)Fmkrec0); rec_sym = newintsym("rec.field",sSBINARY,(wtruc)Srecfield); pointrsym = newsym("pointer", sTYPESPEC, nil); derefsym = newintsym("^", sSBINARY,(wtruc)Sderef); nullstring= mknullstr(); stringsym = newsym("string", sTYPESPEC, nullstring); str_sym = new0symsig("string",sFBINARY,(wtruc)Ftextstring, s_1); mkstrsym = newintsym("string[]",sFBINARY, (wtruc)Fmkstring); nullbstring= mknullbstr(); bstringsym= newsym("byte_string", sTYPESPEC, nullbstring); bstr_sym = new0symsig("byte_string",sFBINARY,(wtruc)Fbstring, s_12); mkbstrsym = newintsym("$", sFBINARY, (wtruc)Fmkbstring); temp = newintsym("", sSBINARY, (wtruc)mkstack); stacksym = newsym("stack", sTYPESPEC, mk0fun(temp)); charsym = newsym("char", sTYPESPEC, mkchar(' ')); vectorsym = newintsym("vector", sFBINARY, (wtruc)Fvector); pairsym = newintsym("pair", sFBINARY, (wtruc)Fpair); mkarrsym = newintsym("mkarray",sFBINARY,(wtruc)Fmkarray); mknewsym = newsymsig("new", sSBINARY,(wtruc)Snew,s_1); allocsym = newsymsig("alloc", sFBINARY,(wtruc)Falloc,s_23); reallocsym= newsymsig("realloc",sSBINARY,(wtruc)Srealloc,s_23); vrtrimsym = newsymsig("vect_rtrim", sFBINARY,(wtruc)Fvectrtrim,s_1); pushsym = newsymsig("stack_push", sFBINARY,(wtruc)Fstkpush,s_2); arrpushsym = newsymsig("stack_arraypush", sFBINARY,(wtruc)Fstkarrpush,s_23); popsym = newsymsig("stack_pop", sFBINARY,(wtruc)Fstkpop, s_1); topsym = newsymsig("stack_top", sFBINARY,(wtruc)Fstktop, s_1); resetsym = newsymsig("stack_reset",sFBINARY,(wtruc)Fstkreset, s_1); emptysym = newsymsig("stack_empty",sFBINARY,(wtruc)Fstkempty, s_1); stk2arrsym= newsymsig("stack2array",sFBINARY,(wtruc)Fstk2array, s_1); stk2strsym= newsymsig("stack2string",sFBINARY,(wtruc)Fstk2string, s_1); maxarrsym = newsymsig("max_arraysize",sFBINARY,(wtruc)Fmaxarray, s_0); mbtestsym = newsymsig("mem_btest", sSBINARY,(wtruc)Smembtest, s_2); mbsetsym = newsymsig("mem_bset", sSBINARY,(wtruc)Smembset, s_2); mbclrsym = newsymsig("mem_bclear", sSBINARY,(wtruc)Smembclear, s_2); mshiftsym = newsymsig("mem_shift", sSBINARY,(wtruc)Smemshift, s_2); mandsym = newsymsig("mem_and", sSBINARY,(wtruc)Smemand, s_2); morsym = newsymsig("mem_or", sSBINARY,(wtruc)Smemor, s_2); mxorsym = newsymsig("mem_xor", sSBINARY,(wtruc)Smemxor, s_2); mnotsym = newsymsig("mem_not", sSBINARY,(wtruc)Smemnot, s_1); mbitswsym = newsymsig("mem_bitswap",sSBINARY,(wtruc)Smembitsw, s_1); mbyteswsym= newsymsig("mem_byteswap",sSBINARY,(wtruc)Smembytesw,s_2); argvsym = newsym("ARGV", sSYSTEMVAR, nullsym); } /*--------------------------------------------------------------------*/ PUBLIC void iniargv(argc,argv) int argc; char *argv[]; { truc obj; int i; if(argc > ARGCMAX) argc = ARGCMAX; for(i=0; i= 0) *ptr++ = *argptr++; return(obj); } /*--------------------------------------------------------------------*/ PRIVATE truc Fpair() { return(mkntuple(fTUPLE,argStkPtr-1,2)); } /*--------------------------------------------------------------------*/ PRIVATE truc Falloc(argn) int argn; /* argn = 2 or 3 */ { truc *argptr; int flg, flg1; int ch; argptr = argStkPtr - argn + 1; if(*argptr == arraysym) return(Fmkarray(argn-1)); else if(*argptr == stringsym) { flg = fSTRING; ch = ' '; } else if(*argptr == bstringsym) { flg = fBYTESTRING; ch = 0; } else { error(allocsym,err_syarr,*argptr); return(brkerr()); } if(argn == 3) { flg1 = *FLAGPTR(argStkPtr); if(flg1 == fCHARACTER || flg1 == fFIXNUM) { ch = *WORD2PTR(argStkPtr); if(*SIGNPTR(argStkPtr)) ch = -ch; } } return(mkstring(argptr+1,flg,ch)); } /*--------------------------------------------------------------------*/ PRIVATE truc Fmkarray(argn) int argn; /* argn = 1 or 2 */ { truc *argptr, *ptr; truc vector, ele; unsigned i, len; int flg; argptr = argStkPtr - argn + 1; flg = *FLAGPTR(argptr); if(flg != fFIXNUM || *SIGNPTR(argptr)) { error(allocsym,err_pfix,*argptr); /* vorlaeufig */ return(brkerr()); } len = *WORD2PTR(argptr); vector = mkvect0(len); if(argn == 1) { return(vector); } WORKpush(vector); if(!len) len = 1; if(*FLAGPTR(argStkPtr) >= fBOOL) { ele = *argStkPtr; ptr = VECTORPTR(workStkPtr); while(len--) *ptr++ = ele; } else { for(i=0; i len, i.e. proper realloc */ if(argn == 3) { res = eval(ARGNPTR(evalStkPtr,3)); ARGpush(res); } else if(flg == fVECTOR) ARGpush(zero); if(flg != fVECTOR) { /* flg == fSTRING || flg == fBYTESTRING */ if(argn == 3) { flg1 = *FLAGPTR(argStkPtr); if(flg1 == fCHARACTER || flg1 == fFIXNUM) { ch = *WORD2PTR(argStkPtr); if(*SIGNPTR(argStkPtr)) ch = -ch; } else { ch = 0; } ARGpop(); } else { ch = 0; } string = (flg == fSTRING ? mkstr0(len1) : mkbstr0(len1)); cpt1 = STRINGPTR(&string); cpt2 = STRINGPTR(argStkPtr); for(k=0; k= fBOOL) { ele = *argStkPtr; for(k=len; k 0xFFFF) { error(concatsym,err_2long,voidsym); return(brkerr()); } else { n = len; } strobj = mkstr0(n); str = STRING(strobj); for(i=0; i len) return(-1); diff = len - len1; ch = *sub++; for(i=0; i<=diff; i++) { if(*str++ != ch) continue; ptr = str; ptr1 = sub; res = i; for(k=1; k= 0) return(res); } return(-1); } /*--------------------------------------------------------------------*/ PRIVATE truc Fstrsplit(argn) int argn; { truc *vptr, *basptr; truc *argptr; truc obj; word2 *offsets; char *trenn; char *str, *str0; unsigned len; int k, count, flg; if(argn == 2) { flg = *FLAGPTR(argStkPtr); if(flg != fSTRING) { error(splitsym,err_str,*argStkPtr); return(brkerr()); } trenn = STRINGPTR(argStkPtr); } else { trenn = NULL; } argptr = argStkPtr - argn + 1; flg = *FLAGPTR(argptr); if(flg != fSTRING) { error(splitsym,err_str,*argptr); return(brkerr()); } str = STRINGPTR(argptr); len = *STRLENPTR(argptr); if(len > sizeof(word2) * (aribufSize/2-1)) { error(splitsym,err_2long,mkfixnum(len)); return(brkerr()); } str0 = (char *)AriBuf; strncopy(str0,str,len); offsets = AriBuf + aribufSize/2; count = stringsplit(str0,trenn,offsets); basptr = workStkPtr + 1; for(k=0; k= 0) *pt4++ = 0; sep = (byte *)sep4; if(trenn == NULL) trenn = trenn0; while((ch = *(byte *)trenn++)) sep[ch] = 1; k = count = 0; while(1) { while((ch = *(byte *)str++) && sep[ch]) k++; if(!ch) break; offsets[count++] = k++; while((ch = *(byte *)str++) && !sep[ch]) k++; if(!ch) break; str[-1] = 0; k++; } return(count); } /*--------------------------------------------------------------------*/ /* ** string_scan(s,bag: string): integer; ** returns the position in s of the first character that belongs to bag; ** if there is no such character, -1 is returned ** string_scan(s,bag: string; false): integer; ** returns the position in s of the first character that does not ** belong to bag; if all characters of s also belog to bag, ** -1 is returned */ PRIVATE truc Fstrscan(argn) int argn; { truc *argptr; byte *str, *bag, *sep; int flg, tst, ch; int k, len, len2, pos; word4 sep4[64]; /* space for 256 bytes */ word4 *pt4; word4 fill; if(argn == 3 && (*argStkPtr == zero || *argStkPtr == false)) { fill = 0xFFFFFFFF; tst = 0; } else { fill = 0; tst = 0xFF; } argptr = argStkPtr - argn + 1; for(k=0; k<2; k++) { flg = *FLAGPTR(argptr+k); if(flg != fSTRING && flg != fBYTESTRING) { error(sscansym,err_str,argptr[k]); return(brkerr()); } } str = BYTEPTR(argptr); len = *STRLENPTR(argptr); bag = BYTEPTR(argptr+1); len2 = *STRLENPTR(argptr+1); k = 64; pt4 = sep4; while(--k >= 0) *pt4++ = fill; sep = (byte *)sep4; for(k=0; k fVECTLIKE1) { error(subarrsym,err_arr,argStkPtr[-1]); return(brkerr()); } len = *VECLENPTR(argStkPtr-1); if(indrange(argStkPtr,len,&n0,&n1) == aERROR) { return(brkerr()); } len0 = n1 - n0 + 1; if(flg == fVECTOR) { obj = mkvect0((unsigned)len0); ptr1 = VECTORPTR(argStkPtr-1) + n0; ptr = VECTOR(obj); while(--len0 >= 0) *ptr++ = *ptr1++; return(obj); } if(flg == fSTRING) obj = mkstr0((unsigned)len0); else if(flg == fBYTESTRING) obj = mkbstr0((unsigned)len0); else /* this case should not happen */ return(brkerr()); /* case fSTRING or fBYTESTRING */ cptr1 = STRINGPTR(argStkPtr-1) + n0; cptr = STRING(obj); while(--len0 >= 0) *cptr++ = *cptr1++; *cptr = 0; return(obj); } /*--------------------------------------------------------------------*/ PRIVATE int indrange(ptr,len,pn0,pn1) truc *ptr; long len; long *pn0, *pn1; { long n0, n1; int ret = 0; ptr = VECTORPTR(ptr); if(*FLAGPTR(ptr) == fFIXNUM) { n0 = *WORD2PTR(ptr); if(*SIGNPTR(ptr)) n0 = 0; } else goto errexit; ptr++; if(*FLAGPTR(ptr) == fFIXNUM) { n1 = *WORD2PTR(ptr); if(*SIGNPTR(ptr)) n1 = -1; } else if(*ptr == endsym) { n1 = len-1; } else goto errexit; if(n1 > len-1) n1 = len-1; if(n0 > n1) n0 = n1+1; *pn0 = n0; *pn1 = n1; return(ret); errexit: error(subarrsym,err_sarr,voidsym); return(aERROR); } /*--------------------------------------------------------------------*/ PRIVATE int arrindex(ptr,pindex) truc *ptr; long *pindex; { long index; int flg, flg1; word2 *z; int sign, n; flg = *FLAGPTR(ptr); if(flg < fVECTLIKE0 && flg > fVECTLIKE1) { error(arr_sym,err_arr,*ptr); return(aERROR); } ptr++; flg1 = *FLAGPTR(ptr); if(flg1 == fFIXNUM) { index = *WORD2PTR(ptr); if(*SIGNPTR(ptr)) index = -index; *pindex = index; } else if(flg1 == fBIGNUM) { n = bigref(ptr,&z,&sign); if ((n > 2) || (n == 2 && z[1] > 0x7FFF)) { error(arr_sym,err_p4int,*ptr); return(aERROR); } else { index = (long)big2long(z,n); if(sign) index = -index; *pindex = index; } } else { /* vorlaeufig */ error(arr_sym,err_pfix,*ptr); return(aERROR); } return(flg); } /*--------------------------------------------------------------------*/ PRIVATE char *stringele(ptr,index) truc *ptr; long index; { struct strcell *str; char *cptr; unsigned len; str = (struct strcell *)TAddress(ptr); len = str->len; if(index < 0 || index >= len) { error(arr_sym,err_irange,mkinum(index)); return(NULL); } cptr = &(str->ch0); return(cptr + index); } /*--------------------------------------------------------------------*/ PRIVATE truc *vectele(ptr,index) truc *ptr; long index; { struct vector *vec; truc *ptr1; unsigned len; vec = VECSTRUCTPTR(ptr); len = vec->len; if(index < 0 || index >= len) { error(arr_sym,err_irange,mkinum(index)); return(NULL); } ptr1 = &(vec->ele0); return(ptr1 + index); } /*--------------------------------------------------------------------*/ /* ** arr[0] enthaelt Array, arr[1] den Index ** In die entsprechende Komponente des Arrays wird obj eingetragen */ PUBLIC truc arrassign(arr,obj) truc *arr; truc obj; { truc *ptr; char *cptr; variant v; long index; int flg; int ch; flg = arrindex(arr,&index); switch(flg) { case fVECTOR: ptr = vectele(arr,index); if(ptr) *ptr = obj; else return(brkerr()); break; case fSTRING: case fBYTESTRING: cptr = stringele(arr,index); if(cptr) { v.xx = obj; flg = v.pp.b0; if(flg == fCHARACTER) ch = v.pp.ww; else if(flg == fFIXNUM) { ch = v.pp.ww; if(v.pp.b1) /* signum */ ch = -ch; arr[2] = mkchar(ch); } else { error(arr_sym,err_char,obj); return(brkerr()); } *cptr = ch; } else return(brkerr()); break; default: return(brkerr()); } return(obj); } /*--------------------------------------------------------------------*/ PRIVATE int arrcompat(flg1,flg2) int flg1, flg2; { if(flg1 < fVECTLIKE0 && flg1 > fVECTLIKE1) return(-1); else if(flg1 == flg2) return(0); else if(flg2 < fVECTLIKE0 && flg2 > fVECTLIKE1) return(-2); else if((flg1 == fVECTOR && flg2 != fVECTOR) || (flg2 == fVECTOR && flg1 != fVECTOR)) return(-3); else return(0); } /*--------------------------------------------------------------------*/ /* ** arr[0] enthaelt Array, arr[1] ein Indexpaar (als fTUPLE der Laenge 2) */ PUBLIC truc subarrassign(arr,obj) truc *arr; truc obj; { truc *ptr, *ptr1; char *cptr, *cptr1; long len, len0, len1, n0, n1; int flg, err; flg = *FLAGPTR(arr); err = arrcompat(flg,Tflag(obj)); if(err < 0) { if(err >= -2) { if(err == -1) obj = arr[0]; error(subarrsym,err_arr,obj); } return(brkerr()); } len = *VECLENPTR(arr); if(indrange(arr+1,len,&n0,&n1) == aERROR) { return(brkerr()); } len0 = n1 - n0 + 1; len1 = VEClen(obj); if(len0 > len1) len0 = len1; switch(flg) { case fVECTOR: ptr1 = VECTORPTR(arr) + n0; ptr = VECTOR(obj); while(--len0 >= 0) *ptr1++ = *ptr++; break; case fSTRING: case fBYTESTRING: cptr1 = STRINGPTR(arr) + n0; cptr = STRING(obj); while(--len0 >= 0) *cptr1++ = *cptr++; break; default: return(brkerr()); } return(obj); } /*--------------------------------------------------------------------*/ PRIVATE long stacklength(ptr) truc *ptr; { struct stack *sptr; long len; sptr = (struct stack *)TAddress(ptr); len = sptr->pageno; len <<= PAGELENBITS; /* times PAGELEN */ len += sptr->line; return(len); } /*--------------------------------------------------------------------*/ /* ** right trim vector without copying *argStkPtr */ PRIVATE truc Fvectrtrim() { int flg, flg1, len; truc *ptr; flg = *FLAGPTR(argStkPtr); if(flg != fVECTOR) { error(vrtrimsym,err_vect,*argStkPtr); return brkerr(); } flg1 = chknumvec(vrtrimsym,argStkPtr); if(flg1 == aERROR) { return brkerr(); } len = *VECLENPTR(argStkPtr); if(len==0) return *argStkPtr; ptr = VECTORPTR(argStkPtr); ptr += len - 1; flg = *FLAGPTR(ptr); if((*ptr == zero) || ((flg >= fFLTOBJ) && (flg & FLTZEROBIT))) { while(--len > 0) { --ptr; flg = *FLAGPTR(ptr); if((*ptr == zero) || ((flg >= fFLTOBJ) && (flg & FLTZEROBIT))) continue; else break; } *VECLENPTR(argStkPtr) = len; } return *argStkPtr; } /*---------------------------------------------------------------------*/ #if 0 /* ** _with_ copying *argStkPtr */ PRIVATE truc Fvectrtrim_() { int flg, flg1, len; truc *ptr; truc dupl[1]; flg = *FLAGPTR(argStkPtr); if(flg != fVECTOR) { error(vrtrimsym,err_vect,*argStkPtr); return brkerr(); } flg1 = chknumvec(vrtrimsym,argStkPtr); if(flg1 == aERROR) { return brkerr(); } len = *VECLENPTR(argStkPtr); if(len==0) return *argStkPtr; ptr = VECTORPTR(argStkPtr); ptr += len - 1; flg = *FLAGPTR(ptr); if((*ptr == zero) || ((flg >= fFLTOBJ) && (flg & FLTZEROBIT))) { while(--len > 0) { --ptr; flg = *FLAGPTR(ptr); if((*ptr == zero) || ((flg >= fFLTOBJ) && (flg & FLTZEROBIT))) continue; else break; } dupl[0] = mkarrcopy(argStkPtr); *VECLENPTR(dupl) = len; return dupl[0]; } else { return *argStkPtr; } } #endif /*--------------------------------------------------------------------*/ PRIVATE truc Fstkpush() { struct stack *sptr; struct stackpage *spage; truc currpage, sheet; truc obj; int line; if(*FLAGPTR(argStkPtr-1) != fSTACK) { error(pushsym,err_stkv,voidsym); return(brkerr()); } if(*argStkPtr == breaksym) return(brkerr()); obj = mkcopy(argStkPtr); /* 20070724 */ WORKpush(obj); sptr = (struct stack *)TAddress(argStkPtr-1); line = sptr->line; if(line == 0) { /* create new page */ sheet = mkvect0(PAGELEN+1); sptr = (struct stack *)TAddress(argStkPtr-1); currpage = sptr->page; sptr->page = sheet; spage = (struct stackpage *)Taddress(sheet); spage->prevpage = currpage; } else spage = (struct stackpage *)Taddress(sptr->page); spage->data[line] = WORKretr(); /* 20070724 */ line++; if(line >= PAGELEN) { line = 0; sptr->pageno++; } sptr->line = line; return *argStkPtr; } /*--------------------------------------------------------------------*/ /* ** stack_arraypush(st: stack; vec: array [; direction: integer]): integer; */ PRIVATE truc Fstkarrpush(argn) int argn; { struct stack *sptr; struct stackpage *spage; struct vector *vecstruct; truc *argptr, *vec; truc currpage, sheet; int line, incr; unsigned len, pos, k; argptr = argStkPtr-argn+1; if(*FLAGPTR(argptr) != fSTACK) { error(arrpushsym,err_stkv,voidsym); return(brkerr()); } if(*FLAGPTR(argptr+1) != fVECTOR) { error(arrpushsym,err_vect,argptr[1]); return(brkerr()); } if(argn == 3) { if(*FLAGPTR(argStkPtr) != fFIXNUM) { error(arrpushsym,"integer +1 or -1 expected",*argStkPtr); return(brkerr()); } incr = (*SIGNPTR(argStkPtr) ? -1 : 1); } else incr = 1; vecstruct = VECSTRUCTPTR(argptr+1); vec = &(vecstruct->ele0); len = vecstruct->len; if(len == 0) return zero; pos = (incr > 0 ? 0 : len-1); sptr = (struct stack *)TAddress(argptr); spage = (struct stackpage *)Taddress(sptr->page); line = sptr->line; for(k=0; kpage; sptr->page = sheet; spage = (struct stackpage *)Taddress(sheet); spage->prevpage = currpage; vec = VECTORPTR(argptr+1); /* may have changed during gc */ } spage->data[line] = vec[pos]; line++; if(line >= PAGELEN) { line = 0; sptr->pageno++; } } sptr->line = line; return(mkfixnum(len)); } /*--------------------------------------------------------------------*/ PRIVATE truc Fstkpop() { return(Gstkretr(popsym)); } /*--------------------------------------------------------------------*/ PRIVATE truc Fstktop() { return(Gstkretr(topsym)); } /*--------------------------------------------------------------------*/ PRIVATE truc Gstkretr(symb) truc symb; { struct stack *sptr; struct stackpage *spage; truc currpage, obj; int line; if(*FLAGPTR(argStkPtr) != fSTACK) { error(symb,err_stkv,voidsym); return(brkerr()); } sptr = (struct stack *)TAddress(argStkPtr); line = sptr->line; currpage = sptr->page; if(currpage == nullsym) { error(symb,err_stke,voidsym); return(brkerr()); } spage = (struct stackpage *)Taddress(currpage); line = (line > 0 ? line-1 : PAGELEN-1); obj = spage->data[line]; if(symb == popsym) { sptr->line = line; if(line == 0) /* delete current page */ sptr->page = spage->prevpage; else if(line == PAGELEN-1) sptr->pageno--; } return(obj); } /*--------------------------------------------------------------------*/ PRIVATE truc Fstk2array() { struct stack *sptr; struct stackpage *spage; truc currpage; truc *vec; truc arr; long llen; unsigned len; int lineno, pageno; if(*FLAGPTR(argStkPtr) != fSTACK) { error(stk2arrsym,err_stkv,voidsym); return(brkerr()); } sptr = (struct stack *)TAddress(argStkPtr); pageno = sptr->pageno; lineno = sptr->line; llen = pageno; llen <<= PAGELENBITS; /* times PAGELEN */ llen += lineno; if(llen > (long)getblocksize()) { error(stk2arrsym,err_stkbig,voidsym); return(brkerr()); } len = llen; arr = mkvect0(len); vec = VECTORPTR(&arr); if(len == 0) goto ausgang; sptr = (struct stack *)TAddress(argStkPtr); /* may have changed after garbage collection */ currpage = sptr->page; spage = (struct stackpage *)Taddress(currpage); lineno = (lineno > 0 ? lineno-1 : PAGELEN-1); while(len > 0) { len--; vec[len] = spage->data[lineno]; lineno--; if(lineno < 0) { lineno += PAGELEN; if(--pageno < 0) break; currpage = spage->prevpage; spage = (struct stackpage *)Taddress(currpage); } } sptr->line = 0; sptr->pageno = 0; sptr->page = nullsym; ausgang: return(arr); } /*--------------------------------------------------------------------*/ PRIVATE truc Fstk2string() { struct stack *sptr; struct stackpage *spage; truc currpage; truc *ptr; char *str, *str1, *str2; long llen; unsigned len, mlen, slen, pos, k; int lineno, pageno; int flg; if(*FLAGPTR(argStkPtr) != fSTACK) { error(stk2arrsym,err_stkv,voidsym); return(brkerr()); } sptr = (struct stack *)TAddress(argStkPtr); pageno = sptr->pageno; lineno = sptr->line; llen = pageno; llen <<= PAGELENBITS; /* times PAGELEN */ llen += lineno; mlen = (getblocksize()-1) & 0xFFFC; if(llen > (long)mlen) goto errexit; len = llen; pos = aribufSize*sizeof(word2) & 0xFFFC; if(pos/4 > mlen) pos = 4*mlen; str = (char*)AriBuf; str[pos] = '\0'; currpage = sptr->page; spage = (struct stackpage *)Taddress(currpage); lineno = (lineno > 0 ? lineno-1 : PAGELEN-1); while(len > 0) { len--; ptr = spage->data + lineno; flg = *FLAGPTR(ptr); if(flg == fCHARACTER) { if(pos > 0) { pos--; str[pos] = *WORD2PTR(ptr); } else goto errexit; } else if(flg == fSTRING) { str2 = STRINGPTR(ptr); slen = *STRLENPTR(ptr); if(pos >= slen) { pos -= slen; for(str1=str+pos, k=0; kprevpage; spage = (struct stackpage *)Taddress(currpage); } } sptr->line = 0; sptr->pageno = 0; sptr->page = nullsym; return(mkstr(str+pos)); errexit: error(stk2strsym,err_stkbig,voidsym); return(brkerr()); } /*--------------------------------------------------------------------*/ PRIVATE truc Fstkreset() { struct stack *sptr; if(*FLAGPTR(argStkPtr) != fSTACK) { error(resetsym,err_stkv,voidsym); return(brkerr()); } sptr = (struct stack *)TAddress(argStkPtr); sptr->line = 0; sptr->pageno = 0; sptr->page = nullsym; return(zero); } /*--------------------------------------------------------------------*/ PRIVATE truc Fstkempty() { struct stack *sptr; if(*FLAGPTR(argStkPtr) != fSTACK) { error(emptysym,err_stkv,voidsym); return(brkerr()); } sptr = (struct stack *)TAddress(argStkPtr); return(sptr->page == nullsym ? true : false); } /*--------------------------------------------------------------------*/ PRIVATE truc Fmaxarray() { unsigned len = getblocksize(); return(mkfixnum((len-1) & 0xFFFC)); } /*--------------------------------------------------------------------*/ #ifdef QUICKSORT typedef int (*ifunvv)(const void *, const void *); PUBLIC void sortarr(arr,len,cmpfn) truc *arr; unsigned len; ifuntt cmpfn; { qsort(arr,(size_t)len,sizeof(truc),(ifunvv)cmpfn); } #else /*---------------------------------------------------------*/ /* ** destructively shellsorts array arr[0],...,arr[len-1] ** with ordering given by ** int cmpfn(truc *ptr1, truc *ptr2); ** arr should be safe w.r.t garbage collection in case cmpfn ** allocates new memory */ PUBLIC void sortarr(arr,len,cmpfn) truc *arr; unsigned len; ifuntt cmpfn; { #define DDLEN 14 static unsigned dd[DDLEN] = {1,3,7,17,37,83,191,421,929,2053,4517,9941,21871,0xFFFF}; unsigned i, k, d; int n = 0; ARGpush(zero); while(n < DDLEN && dd[n] < len) n++; while(--n >= 0) { d = dd[n]; i = len - d; while(i) { *argStkPtr = arr[--i]; k = i + d; while(k 0) { arr[k-d] = arr[k]; k += d; } arr[k-d] = *argStkPtr; } } ARGpop(); } #endif /* QUICKSORT */ /*---------------------------------------------------------*/ PRIVATE int tttype; PRIVATE int compfun(ptr1,ptr2) truc *ptr1, *ptr2; { char *str1, *str2; if(tttype >= fFIXNUM) return(cmpnums(ptr1,ptr2,tttype)); else if(tttype == fSTRING) { str1 = STRINGPTR(ptr1); str2 = STRINGPTR(ptr2); return(strcmp(str1,str2)); } else return(0); /* this case should not happen */ } /*---------------------------------------------------------*/ PRIVATE truc *usercmpfun; PRIVATE int ucompfun(ptr1,ptr2) truc *ptr1, *ptr2; { truc argv[2]; truc res; int flg; argv[0] = *ptr1; argv[1] = *ptr2; res = ufunapply(usercmpfun,argv,2); if(res == zero) return(0); else if((flg = *FLAGPTR(&res)) == fFIXNUM) return(*SIGNPTR(&res) ? -1 : 1); else if(flg == fBIGNUM) return(*SIGNUMPTR(&res) ? -1 : 1); else { error(sortsym,err_case,mkfixnum(flg)); return(aERROR); } } /*---------------------------------------------------------*/ PRIVATE truc Ssort() { struct fundef *fundefptr; struct symbol *sptr; truc *argptr; truc *ptr; truc obj, fun; int argn; argn = *ARGCOUNTPTR(evalStkPtr); if(argn == 1) { argptr = ARG1PTR(evalStkPtr); return(Hsort1(argptr)); } else { /* argn == 2, second argument is compare function */ ptr = ARGNPTR(evalStkPtr,2); obj = eval(ptr); if(Tflag(obj) != fSYMBOL) goto errexit; sptr = symptr(obj); if(*FLAGPTR(sptr) != sFUNCTION) goto errexit; fun = sptr->bind.t; fundefptr = (struct fundef *)Taddress(fun); if(fundefptr->argc != 2) goto errexit; argptr = ARG1PTR(evalStkPtr); WORKpush(*argptr); obj = Hsort2(workStkPtr,fun); WORKpop(); return(obj); errexit: error(sortsym,"bad compare function",obj); return(brkerr()); } } /*---------------------------------------------------------*/ PRIVATE truc Hsort1(argptr) truc *argptr; { truc *arr; truc *vptr; unsigned k, len; int flg0, flg; flg0 = vectaddr(argptr,&vptr,&arr,&len); if(flg0 == aERROR) { error(sortsym,err_vect,*argptr); return(brkerr()); } if(!len) return(eval(argptr)); flg = *FLAGPTR(arr); if(flg >= fFIXNUM) flg = chknums(sortsym,arr,len); else if(flg == fSTRING) { for(k=1; k= fFIXNUM || flg == fSTRING) { return Hbsearch1(argptr,vptr,flg); } else { error(bsearchsym,"lacking compare function",voidsym); return(brkerr()); } } else { /* argn=3, user supplied compare function */ if(*FLAGPTR(argStkPtr) != fSYMBOL) goto badcompare; sptr = SYMPTR(argStkPtr); if(*FLAGPTR(sptr) != sFUNCTION) goto badcompare; *argStkPtr = sptr->bind.t; if(*FUNARGCPTR(argStkPtr) != 2) goto badcompare; usercmpfun = argStkPtr; /* global variable */ n1 = 0; n2 = *VECLENPTR(vptr); while(n2 > n1) { m = (n1 + n2)/2; ele = VECTORPTR(vptr) + m; vergl = ucompfun(argptr,ele); if(vergl < 0) n2 = m; else if(vergl > 0) n1 = m+1; else return(mkfixnum(m)); } return(mksfixnum(-1)); } badcompare: error(bsearchsym,"bad compare function",voidsym); return(brkerr()); } /*---------------------------------------------------------*/ /* ** binary search in array of numbers or strings */ PRIVATE truc Hbsearch1(ele,vptr,flg) truc *ele, *vptr; int flg; { int flg1, vergl; truc *arr; unsigned n1, n2, m; arr = VECTORPTR(vptr); n1 = 0; n2 = *VECLENPTR(vptr); if(flg == fSTRING) { tttype = flg; while(n2 > n1) { m = (n1 + n2)/2; flg1 = *FLAGPTR(arr+m); if(flg1 != flg) { error(bsearchsym,err_str,arr[m]); return(brkerr()); } vergl = compfun(ele,arr+m); if(vergl < 0) n2 = m; else if(vergl > 0) n1 = m+1; else return(mkfixnum(m)); } return(mksfixnum(-1)); } else if(flg >= fFIXNUM) { while(n2 > n1) { m = (n1 + n2)/2; flg1 = *FLAGPTR(arr+m); if(flg1 < fFIXNUM) { error(bsearchsym,err_num,arr[m]); return(brkerr()); } tttype = (flg1 > flg ? flg1 : flg); vergl = compfun(ele,arr+m); if(vergl < 0) n2 = m; else if(vergl > 0) n1 = m+1; else return(mkfixnum(m)); } return(mksfixnum(-1)); } else { error(bsearchsym,err_case,voidsym); return(brkerr()); } } /*---------------------------------------------------------*/ PRIVATE int vectaddr(ptr,ppvec,parr,plen) truc *ptr; truc **ppvec; truc **parr; unsigned *plen; { truc *vecptr; truc *arr; long len, n0, n1; int ret; ret = Lvaladdr(ptr,&vecptr); switch(ret) { case vARRELE: case vRECFIELD: vecptr = Ltrucf(ret,vecptr); if(vecptr == NULL) return(aERROR); /* else fall through */ case vBOUND: if(*FLAGPTR(vecptr) != fVECTOR) { return(aERROR); } len = *VECLENPTR(vecptr); arr = VECTORPTR(vecptr); break; case vSUBARRAY: ARGpush(vecptr[1]); ARGpush(vecptr[2]); argStkPtr[-1] = eval(argStkPtr-1); argStkPtr[0] = eval(argStkPtr); vecptr = argStkPtr-1; if(*FLAGPTR(vecptr) != fVECTOR) { ARGnpop(2); return(aERROR); } len = *VECLENPTR(vecptr); ret = indrange(argStkPtr,len,&n0,&n1); ARGnpop(2); if(ret == aERROR) { return(aERROR); } len = n1 - n0 + 1; arr = VECTORPTR(vecptr) + (size_t)n0; break; default: return(aERROR); } *ppvec = vecptr; *parr = arr; *plen = (unsigned)len; return(ret); } /*---------------------------------------------------------*/ PUBLIC int bytestraddr(ptr,ppbstr,ppch,plen) truc *ptr; truc **ppbstr; byte **ppch; unsigned *plen; { struct strcell *string; truc *bstrptr; byte *cpt; long len, n0, n1; int flg, ret; ret = Lvaladdr(ptr,&bstrptr); switch(ret) { case vARRELE: case vRECFIELD: bstrptr = Ltrucf(ret,bstrptr); if(bstrptr == NULL) return(aERROR); /* else fall through */ case vBOUND: flg = *FLAGPTR(bstrptr); if(flg != fBYTESTRING && flg != fSTRING) { return(aERROR); } string = STRCELLPTR(bstrptr); len = string->len; cpt = (byte *)&(string->ch0); break; case vSUBARRAY: ARGpush(bstrptr[1]); ARGpush(bstrptr[2]); argStkPtr[-1] = eval(argStkPtr-1); argStkPtr[0] = eval(argStkPtr); bstrptr = argStkPtr-1; flg = *FLAGPTR(bstrptr); if(flg != fBYTESTRING && flg != fSTRING) { ARGnpop(2); return(aERROR); } string = STRCELLPTR(bstrptr); ret = indrange(argStkPtr,(long)string->len,&n0,&n1); ARGnpop(2); if(ret == aERROR) { return(aERROR); } len = n1 - n0 + 1; cpt = (byte *)&(string->ch0) + (size_t)n0; break; default: return(aERROR); } *ppbstr = bstrptr; *ppch = cpt; *plen = (unsigned)len; return(flg); } /*---------------------------------------------------------*/ PRIVATE truc *Ltrucf(flg,pptr) int flg; truc *pptr; { truc *ptr; long n0; switch(flg) { case vARRELE: ARGpush(pptr[1]); ARGpush(pptr[2]); argStkPtr[-1] = eval(argStkPtr-1); argStkPtr[0] = eval(argStkPtr); flg = arrindex(argStkPtr-1,&n0); if(flg == fVECTOR) { ptr = vectele(argStkPtr-1,n0); } else { ptr = NULL; } ARGnpop(2); break; case vRECFIELD: ARGpush(pptr[1]); *argStkPtr = eval(argStkPtr); ptr = recfield(argStkPtr,pptr[2]); ARGpop(); break; default: ptr = NULL; } return(ptr); } /*--------------------------------------------------------------------*/ PRIVATE truc Ftextstring() { variant v; int flg; flg = *FLAGPTR(argStkPtr); if(flg == fSTRING) { return(*argStkPtr); } else if(flg != fBYTESTRING) { error(str_sym,err_bystr,*argStkPtr); return(brkerr()); } else { /* flg == fBYTESTRING */ *argStkPtr = mkcopy(argStkPtr); } v.xx = *argStkPtr; v.pp.b0 = fSTRING; return(v.xx); } /*---------------------------------------------------------*/ /* ** byte_string(x,n: integer): byte_string; ** Interpretiert integer x als byte_string der Laenge n; ** negative Zahlen in Zweier-Komplement-Darstellung ** byte_string(s: string): byte_string; ** verwandelt string in byte_string; */ PRIVATE truc Fbstring(argn) int argn; { truc *argptr; truc bstr; word2 *x; byte *ptr; unsigned len, i, m; unsigned u, v; int flg, n, sign, pad; variant vv; argptr = argStkPtr - argn + 1; flg = *FLAGPTR(argptr); if(argn == 1) { if(flg == fSTRING) { *argStkPtr = mkcopy(argStkPtr); vv.xx = *argStkPtr; vv.pp.b0 = fBYTESTRING; return(vv.xx); } else if(flg == fBYTESTRING) { return *argStkPtr; } } if(flg < fINTTYPE0 || flg > fINTTYPE1) { error(bstringsym,err_intt,*argptr); return(brkerr()); } if(argn == 2) { if((*FLAGPTR(argStkPtr) != fFIXNUM) || *SIGNPTR(argStkPtr)) { error(bstringsym,err_pfix,*argStkPtr); return(brkerr()); } len = *WORD2PTR(argStkPtr); } else { n = bigref(argStkPtr,&x,&sign); len = (bit_length(x,n) + 7) >> 3; } bstr = mkbstr0(len); ptr = (byte *)STRING(bstr); x = AriBuf; if(flg == fGF2NINT) { n = bigretr(argptr,x,&sign); pad = 0; } n = twocretr(argptr,x); pad = (n >= (len+1)/2 ? 0 : 1); m = (pad ? n : len/2); if(pad) v = x[n]; /* 0x00 or 0xFF */ for(i=0; i> 8); } if(!pad && (len & 1)) { *ptr = *x; } else if(pad) { len -= 2*m; for(i=0; i> 3; k = pos & 0x7; mask <<= k; if(symb == mbtestsym) { if(pos < 0 || n >= len) return(zero); else if(cpt[n] & mask) return(constone); else return(zero); } if(pos >= 0 && n < len) { if(symb == mbsetsym) cpt[n] |= mask; else if(symb == mbclrsym) cpt[n] &= ~mask; } return(*bstrptr); errexit: error(symb,err_vbystr,*argptr); return(brkerr()); } /*---------------------------------------------------------*/ PRIVATE truc GmemBB(symb) truc symb; { truc *argptr, *bstrptr, *bstrptr2; byte *cpt, *cpt2; unsigned len, len2, u; int ret; argptr = ARG0PTR(evalStkPtr); ret = bytestraddr(argptr,&bstrptr,&cpt,&len); if(ret != fBYTESTRING) goto errexit; if(symb == mnotsym) { while(len--) { u = *cpt; *cpt++ = ~u; } return(*bstrptr); } else if(symb == mbitswsym) { while(len--) { u = *cpt; *cpt++ = BitSwap[u]; } return(*bstrptr); } WORKpush(*bstrptr); argptr = ARG1PTR(evalStkPtr); ret = bytestraddr(argptr,&bstrptr2,&cpt2,&len2); if(ret != fBYTESTRING) goto errexit2; if(len2 < len) len = len2; if(symb == mxorsym) { while(len--) *cpt++ ^= *cpt2++; } else if(symb == mandsym) { while(len--) *cpt++ &= *cpt2++; } else if(symb == morsym) { while(len--) *cpt++ |= *cpt2++; } return(WORKretr()); errexit2: WORKpop(); errexit: error(symb,err_vbystr,*argptr); return(brkerr()); } /*---------------------------------------------------------*/ PRIVATE void byteshift(ptr,len,sh) byte *ptr; unsigned len; long sh; { word4 k; unsigned m, sh0, sh1; k = (sh > 0 ? sh >> 3 : (-sh) >> 3); if(k >= len) { for(m=0; m 0 ? sh & 0x7 : (-sh) & 0x7); if(sh > 0) { if(k) { for(m=len; m>k; --m) ptr[m-1] = ptr[m-k-1]; for(m=0; mk; m--) ptr[m] = (ptr[m] << sh0) | (ptr[m-1] >> sh1); ptr[k] <<= sh0; } } else if(sh < 0) { if(k) { for(m=k; m>sh0) | (ptr[m]<>= sh0; } } } /*---------------------------------------------------------*/ PRIVATE void byteswap(ptr,len,grp) byte *ptr; unsigned len, grp; { byte *ptr1, *ptr2; unsigned x,k; if(len < grp || !grp) return; len -= grp; for(k=0; k<=len; k+=grp,ptr+=grp) { ptr1 = ptr; ptr2 = ptr1 + grp - 1; while(ptr2 > ptr1) { x = *ptr1; *ptr1++ = *ptr2; *ptr2-- = x; } } } /*--------------------------------------------------------------------*/ /* ** Beschafft die Addresse einer Pointer-Variablen */ PRIVATE int Paddr(ptr,pvptr) truc *ptr; trucptr *pvptr; { truc *vptr; int ret; ret = Lvaladdr(ptr,&vptr); switch(ret) { case vBOUND: break; case vARRELE: case vRECFIELD: vptr = Ltrucf(ret,vptr); if(vptr == NULL) return(aERROR); break; default: return(aERROR); } if(*FLAGPTR(vptr) != fPOINTER) ret = aERROR; else *pvptr = vptr; return(ret); } /*--------------------------------------------------------------------*/ /* ** Argument in *argStkPtr ist ein 2n-tupel mit ** n Feldbezeichnungen und n Anfangswerten bzw. Prozeduren, ** die Anfangswerte erzeugen. ** Resultat ein initialisierter Record */ PRIVATE truc Fmkrec0() { truc *ptr; truc obj; unsigned i, n; n = *VECLENPTR(argStkPtr); n /= 2; ptr = VECTORPTR(argStkPtr) + n; for(i=0; iflag != fRECORD || ptr2->len != ptr1->len) { error(assignsym,err_mism,voidsym); return(brkerr()); } ptr2->recdef = ptr1->recdef; return(*rptr = obj); } /*--------------------------------------------------------------------*/ PRIVATE truc *recfield(rptr,field) truc *rptr; truc field; { struct record *sptr; truc *ptr, *fptr; unsigned n, i; int flg; flg = *FLAGPTR(rptr); if(flg == fPOINTER) { sptr = RECORDPTR(rptr); if(sptr->field1 != nil) { rptr = &(sptr->field1); flg = *FLAGPTR(rptr); } } if(flg != fRECORD) { error(recordsym,"record variable expected",*rptr); return(NULL); } ptr = TAddress(rptr); fptr = TAddress(ptr+1); n = *WORD2PTR(fptr) / 2; fptr++; for(i=0; i #include #include #include #include /* ** to compile ARIBAS, one of the following symbols ** must be defined */ /************ #define UNiX #define LiNUX #define SCOUNiX #define DjGPP #define GtK #define MacGtK #define Win32GUI #define Win32CON #define MsDOS #define Dos386 #define Dos286 #define ATARIST ************/ /*-----------------------------------------------------------------*/ #ifdef UNiX #define ARCHITEC "UNIX" #define genUNiX #endif #ifdef SCOUNiX #define ARCHITEC "SCO-UNIX" #define genUNiX #define M_3264 #endif #ifdef LiNUX #ifdef GtK #define genWinGUI #define ARCHITEC "LINUX-GTK" #else #define ARCHITEC "LINUX" #endif #define genUNiX #endif #ifdef MacGtK #define GtK #define genUNiX #define genWinGUI #define ARCHITEC "MacOSX-GTK" #endif #ifdef genUNiX #define DOSorUNiX #define UNiXorGCC #define M_LARGE #endif #ifdef Win32GUI #define ARCHITEC "Win32GUI" #define MsWIN32 #define genWinGUI #endif #ifdef Win32CON #define ARCHITEC "Win32Console" #define MsWIN32 #define LINEINPUT #endif #ifdef MsWIN32 #ifndef NO_ASSEMB #define M_3264 #endif #define M_LARGE #endif #ifdef Dos386 #define ARCHITEC "MS-DOS 386" #define MsDOS #define M_3264 #endif #ifdef Dos286 #define ARCHITEC "MS-DOS 286" #define MsDOS #endif #ifdef MsDOS #ifndef ARCHITEC #define ARCHITEC "MS-DOS 086" #endif #define DOSorUNiX #define DOSorTOS #define M_SMALL #endif #ifdef DjGPP #define ARCHITEC "DJGPP386" #define DOSorUNiX #define UNiXorGCC #define M_3264 #define M_LARGE #endif #ifdef ATARIST #define ARCHITEC "ATARI-ST" #define DOSorTOS #define M_SMALL #endif #ifdef M_LARGE #define FPREC_HIGH #endif /*-----------------------------------------------------------------*/ #define VERSION_STRING "V 1.65b, Aug. 2024" #define VERSION_YEAR "2024" #define VERSION_NO 165 /*-----------------------------------------------------------------*/ #ifdef PROTO #define _(x) x #else #define _(x) () #endif #define PRIVATE static #define PUBLIC /*-----------------------------------------------------------------*/ #ifdef MsDOS #define SHIFTSTAT (*(unsigned char *)0x00000417) #endif #ifdef ATARIST #include #define SHIFTSTAT Kbshift(-1) #endif #ifdef DOSorTOS #define SHIFT 2 /* linke Shift-Taste */ #define CONTROL 4 #define SHCTRL (CONTROL | SHIFT) #ifndef INTERRUPT #define INTERRUPT ((SHIFTSTAT & SHCTRL) == SHCTRL) #endif #endif #ifdef UNiXorGCC #define INTERRUPT Unterbrech #endif #ifdef MsWIN32 #define INTERRUPT Unterbrech #endif /*-----------------------------------------------------------------*/ #define PRIMTABSIZE 2048 /* size of prime bitvector (word2's) */ #define MAXCOLS 80 /* max no. of columns on the screen */ #define ARGCMAX 64 /* maximal length of ARGV */ #ifdef M_LARGE #define IOBUFSIZE 1024 /* size of output buffer */ #define MAXPFADLEN 256 /* avoid name collision with MAXPATHLEN */ #else #define IOBUFSIZE 256 /* size of output buffer */ #define MAXPFADLEN 128 #endif #ifdef genUNiX #define SEPPATH ':' #else #define SEPPATH ';' #endif #ifdef UNiXorGCC #define SEPDIR '/' #else #define SEPDIR '\\' #endif #ifdef genUNiX #define SEP_DIR "/" #endif #ifdef DOSorTOS #define SEP_DIR "\\" #endif #ifdef DjGPP #define SEP_DIR "/\\" #endif #ifndef SEP_DIR #define SEP_DIR "\\/" #endif /*-----------------------------------------------------------------*/ /* values for flag in symbol structure */ /* all values are even, odd values reserved */ #define sUNBOUND 0x00 /* unbound symbol */ #define sVARIABLE 0x02 /* bound variable */ #define sCONSTANT 0x04 /* user defined constant */ #define sFUNCTION 0x06 /* user defined function */ #define sVFUNCTION 0x08 /* user defined function with var args */ #define sTYPEDEF 0x0C /* user defined type */ #define sGCMOVEBIND 0x0E /* mask used during garbage collection */ #define sSYSTEM 0x10 /* all following are system symbols */ #define sFBINARY 0x10 /* builtin function */ #define sSBINARY 0x20 /* builtin special form */ #define sINFIX 0x30 /* infix operator */ #define sSCONSTANT 0x40 /* system constant */ #define sSYMBCONST 0x50 /* symbolic constant */ #define sSYSSYMBOL 0x60 /* system symbol */ #define sPARSAUX 0x70 /* special treatment during parsing */ #define sTYPESPEC 0x80 /* type specifier */ #define sDELIM 0xA0 /* delimiter do, then, else, .., end */ #define sINTERNAL 0xE0 /* internal symbol */ #define sINTERNVAR 0xE2 /* internal var, moved during gc */ #define sSYSTEMVAR 0x12 /* system var, moved during gc */ #define sEXTFUNCTION (0x100 | sFUNCTION) /* used during parsing */ #define mGLOBAL 0x8000 /* to mark external variable */ #define mLOCCONST 0x7000 /* to mark local constants */ /* values for flag of trucs */ /* odd values are fixed during garbage collection */ #define fSYMBOL 1 #define fLSYMBOL 3 /* local symbol */ #define fRSYMBOL 5 /* reference to symbol */ #define fLRSYMBOL 7 /* reference to local symbol */ #define fTMPCONST 9 /* temporary reference to local const */ #define fFUNEXPR 10 /* until fSELFEVAL are kind of functions */ #define fSPECIAL0 11 /* special form, no argument */ #define fSPECIAL1 10 /* special form, 1 argument */ #define fSPECIAL2 12 /* special form, 2 arguments */ #define fSPECIALn 14 /* special form, n arguments */ #define fBUILTIN1 16 /* built-in function, 1 argument */ #define fBUILTIN2 18 /* built-in function, 2 arguments */ #define fBUILTINn 20 /* built-in function, n arguments */ #define fFUNCALL 22 /* call of user defined function */ #define fCOMPEXPR 24 /* compound expression */ #define fIFEXPR 26 /* if statement */ #define fWHILEXPR 28 /* while statement */ #define fFOREXPR 30 /* for statement */ #define fSELFEVAL 32 /* all following are self evaluating */ #define fFUNDEF 32 /* user function definition */ #define fPOINTER 34 #define fTUPLE 36 #define fSTACK 38 #define fSTREAM 40 #define fRECORD 48 #define fVECTLIKE0 50 #define fVECTOR 50 #define fCONSTLIT 52 /* all following are literal objects */ #define fSTRING 52 #define fBYTESTRING 54 #define fVECTLIKE1 54 #define fBOOL 57 #define fCHARACTER 59 #define fINTTYPE0 60 #define fGF2NINT 60 #define fFIXNUM 61 #define fBIGNUM 62 #define fINTTYPE1 62 #define fFLTOBJ 128 #define fHUGEFLOAT (fFLTOBJ + HUGEFLTBIT) #define FIXMASK 0x01 /* mask for checking fixed objects */ #define PRECMASK 0x3E /* mask for retrieving float precision */ #define FLTZEROBIT 0x01 /* for floats = 0 */ #define HUGEFLTBIT 0x40 /* huge floats */ #define HUGEMASK 0x7F #define FSIGNBIT 0x80 /* sign bit in signum of floats */ #define GCMARK 0xFF /* used during garbage collection */ #define MINUSBYTE 0xFF /* sign of negative numbers */ /* streams */ #define INSTREAM 1 /* input stream bit */ #define OUTSTREAM 2 /* output stream bit */ #define IOMASK 3 #define APPEND 8 #define BINARY 16 #define aTEXT 0 /* binary bit not set */ /* avoid nameclash with TEXT in windows header */ #define DEVICE 32 /* console, printer */ #define NOSTREAM 0 /* unconnected stream */ /* values used for reading and printing */ #define EOL '\n' #define FORMFEED '\014' #define TABESC '\036' /* escape char for compression */ #define ZESC '\177' /* tokens for parser */ #define EOFTOK -1 /* end-of-file token */ #define EOLTOK 0 /* end-of-line token */ #define Z1TOK -101 #define LPARENTOK 10 /* ( */ #define RPARENTOK 11 /* ) */ #define LBRACKTOK 12 /* [ */ #define RBRACKTOK 13 /* ] */ #define LBRACETOK 14 /* { */ #define RBRACETOK 15 /* } */ #define BEGCOMMTOK 18 /* (* */ #define ENDCOMMTOK 19 /* *) */ #define COMMATOK 20 #define COLONTOK 21 #define SEMICOLTOK 22 #define DOTTOK 30 #define DOTDOTTOK 31 #define RECDOTTOK 32 /* dot as record field separator */ #define DEREFTOK 40 /* ^ for pointer dereferencing */ #define DOLLARTOK 50 #define HISTORYTOK 60 /* !,!!,!!!,!a,!b,!c */ #define QUESTIONTOK 70 /* ? */ #define ASSIGNTOK 101 /* odd value means right associative */ #define ORTOK 201 #define ANDTOK 211 #define NOTTOK 221 #define EQTOK 300 #define NETOK 310 #define LTTOK 320 #define LETOK 330 #define GTTOK 340 #define GETOK 350 #define PLUSTOK 400 #define MINUSTOK 410 #define TIMESTOK 500 #define DIVIDETOK 510 #define DIVTOK 520 #define MODTOK 540 #define UMINUSTOK 601 #define POWERTOK 701 #define BOOLTOK 2010 #define CHARTOK 2020 /* character token */ #define INUMTOK 2030 /* integer number token */ #define FLOATTOK 2040 #define GF2NTOK 2045 /* gf2n_int token */ #define STRINGTOK 2050 /* string token */ #define BSTRINGTOK 2052 /* byte_string token */ #define SYMBOLTOK 2060 /* symbol token */ #define VECTORTOK 2070 /* vector token */ /* Lvals */ #define vUNBOUND 0 #define vBOUND 1 #define vCONST 2 #define vVECTOR 10 #define vARRELE 11 #define vSUBARRAY 12 #define vRECFIELD 20 #define vPOINTREF 30 /* defines for diverse return values */ #define EXITREQ -1 /* possible return value of loadaux */ #define aERROR -32768 /* error return value for int functions */ /* avoid nameclash with ERROR in windows header */ #define LONGERROR -2147483647 /* error return value for int4 functions */ #define RESET 0x1111 /* value handed by longjmp if reset */ #define HALTRET 0x2222 /* value handed by longjmp if halt */ #define MAXFLTLIM 0x3FFF80 #define MOSTNEGEX -0x400000 /* exponent for float number zero */ /** used by scanner and parser **/ #define TERMINALINP 1 #define FILEINPUT 2 #define STRINGINPUT 3 #define READLNINPUT 4 /*-----------------------------------------------------------------*/ #ifdef M_LARGE typedef int int4; /* 4-byte integer */ typedef unsigned int word4; #else typedef long int4; /* 4-byte integer */ typedef unsigned long word4; #endif typedef short int2; /* 2-byte integer */ typedef unsigned short word2; typedef unsigned char byte; typedef word4 truc; typedef void *wtruc; typedef truc *trucptr; typedef truc (* funptr) (void); typedef truc (* funptr1) (int k); typedef int (* ifun0) (void); typedef int (* ifun) (int x); typedef int (* ifunaa) (word2 *arr1, int n1, word2 *arr2, int n2); typedef int (* ifuntt) (truc *ptr1, truc *ptr2); typedef struct { byte b0; byte b1; word2 ww; } packet; typedef struct { word2 w0; word2 ww; } arr2; typedef union { word4 xx; arr2 yy; packet pp; } variant; typedef union { truc t; wtruc w; } wvariant; struct symbol { /* symbol structure */ truc ident; variant cc; /* information for syntax checking */ wvariant bind; /* symbol binding */ char *name; /* symbol name */ truc *link; /* link to next symbol */ }; #define OFFSETcc 4 #define OFFSETcc1 6 #define OFFSETbind 8 #define OFFSETname (OFFSETbind + sizeof(wtruc)) #define OFFSETlink (OFFSETbind + 2*sizeof(wtruc)) #define SIZEOFSYMBOL (sizeof(struct symbol)/sizeof(truc)) struct intsymbol { /* internal symbol structure */ truc ident; variant cc; wvariant bind; /* symbol binding */ char *name; /* symbol name */ }; #define SIZEOFINTSYMBOL (sizeof(struct intsymbol)/sizeof(truc)) struct floatcell { /* float */ byte flag; byte signum; /* same position as in bigcell */ int2 expo; word2 digi0; word2 digi1; }; #define OFFSETexpo 2 #define OFFSETflodig 4 #define SIZEOFFLOAT(prec) (unsigned)(1 + (prec>>1)) struct bigcell { /* for big integers or gf2nint's */ byte flag; /* = fBIGNUM or fGF2NINT */ byte signum; /* same position as in floatcell */ word2 len; /* same position as in vector */ word2 digi0; word2 digi1; }; /* ** signum = 0 for nonnegative numbers, ** signum = MINUSBYTE for negative numbers */ #define OFFSETsignum 1 #define OFFSETbiglen 2 #define OFFSETbigdig 4 #define SIZEOFBIG(len) (1 + (((unsigned)(len)+1)>>1)) typedef struct { long expo; int sign; int len; word2 *digits; } numdata; struct strcell { /* string */ byte flag; /* = fSTRING */ byte flg2; word2 len; /* same position as in struct vector */ char ch0; char ch1; char ch2; char ch3; }; #define OFFSETstrlen 2 #define OFFSETstring 4 #define SIZEOFSTRING(len) (2 + ((unsigned)(len)>>2)) /* includes '\0' */ struct vector { byte flag; /* = fVECTOR or = fTUPLE */ byte flg2; word2 len; /* same position as in bigcell */ truc ele0; }; #define OFFSETveclen 2 #define OFFSETvector 4 #define SIZEOFTUPLE(len) (1 + (unsigned)(len)) #define SIZEOFVECTOR(len) (unsigned)(len ? (1 + (len)) : 2) /* for arrays of length 0, ele0 contains type */ struct record { /* also used for pointers */ byte flag; /* fRECORD or fPOINTER */ byte flg2; word2 len; /* same position as in vector */ truc recdef; /* fTUPLE with field names and types */ truc field1; truc field2; }; #define SIZEOFRECORD(len) (2 + (unsigned)(len)) #define OFFSETfield1 8 /* for pointers, len = 1, and field1 contains truc ** designating the record pointed to, or nil */ struct stream { /* I/O stream structure */ byte flag; byte mode; /* one of INSTREAM,OUTSTREAM,NOSTREAM */ int2 pos; /* current position in line */ int4 lineno; /* current line number */ int4 ch; /* current character */ int4 tok; /* current token */ FILE *file; /* the file associated with stream */ }; #define OFFSETmode 1 #define OFFSETpos 2 #define OFFSETlineno 4 #define OFFSETch 8 #define OFFSETtok 12 #define OFFSETfile 16 #define SIZEOFSTREAM (sizeof(struct stream)/sizeof(truc)) struct stack { byte flag; byte line; word2 pageno; truc type; /* = zero in this implementation */ truc page; }; #define OFFSETpage 8 #define SIZEOFSTACK 3 /* unit is sizeof(truc) */ #define PAGELENBITS 5 #define PAGELEN 32 /* 2**PAGELENBITS */ struct stackpage { byte flag; /* fVECTOR */ byte flg2; word2 len; /* = PAGELEN + 1 */ truc data[PAGELEN]; truc prevpage; /* for tail rec elimination during gc */ }; struct opnode { truc op; truc arg0; truc arg1; }; #define OFFSETarg0 4 #define OFFSETarg1 8 #define SIZEOFOPNODE(n) (1+(unsigned)(n)) /* unit is sizeof(truc) */ struct funode { truc op; truc argno; /* number of args as FIXNUM */ truc arg1; /* same position as in opnode */ }; #define OFFSETargcount 6 #define OFFSETargn(n) (4 + ((n)<<2)) #define SIZEOFFUNODE(n) (2+(unsigned)(n)) /* unit is sizeof(truc) */ struct fundef { byte flag; /* = fFUNDEF */ byte flg2; /* number of optional arguments */ word2 argc; /* number of formal arguments */ truc varno; /* number of local vars as FIXNUM */ truc body; truc parms; /* default initializations of formal args */ truc vars; /* list of initializations of local vars */ }; #define OFFSETfargc 2 #define OFFSETvarcount 6 #define OFFSETbody 8 #define OFFSETparms 12 #define OFFSETvars 16 #define OFFS4body 2 #define SIZEOFFUNDEF 5 /* unit is sizeof(truc) */ struct compnode { /* compound statement */ byte flag; byte flg2; word2 len; truc expr0; truc expr1; }; #define SIZEOFCOMP(len) (1+(unsigned)(len)) /* unit is sizeof(truc) */ #define OFFSETcomplen 2 struct fornode { byte flag; byte flg2; word2 len; /* len = 4+bodylen, same position as in compnode */ truc runvar; truc start; truc end; truc inc; truc body0; truc body1; }; /*----------------------------------------------------------------*/ /* ** MACROS */ /* TAddress, SAddress, Taddress, Saddress defined in mem0.c */ #define bTAddress(p) ((byte *)TAddress(p)) #define bSAddress(p) ((byte *)SAddress(p)) #define bTaddress(x) ((byte *)Taddress(x)) #define bSaddress(x) ((byte *)Saddress(x)) #define symptr(x) (assert(Tflag(x) == fSYMBOL), (struct symbol *)Saddress(x)) #define streamptr(x) ((struct stream *)Taddress(x)) #define stringptr(x) ((struct strcell *)Taddress(x)) #define recordptr(x) ((struct record *)Taddress(x)) #define FLAG(x) *(byte *)&(x) #define STRING(x) (char *)(bTaddress(x) + OFFSETstring) #define STRlen(x) *(word2 *)(bTaddress(x) + OFFSETstrlen) #define STRMlineno(x) *(int4 *)(bTaddress(x) + OFFSETlineno) #define VECTOR(x) ((truc *)(bTaddress(x) + OFFSETvector)) #define VEClen(x) *(word2 *)(bTaddress(x) + OFFSETveclen) #define PTRtarget(x) *((truc *)(bTaddress(x) + OFFSETfield1)) #define NODEarg0(x) *((truc *)(bTaddress(x) + OFFSETarg0)) #define FLAGPTR(p) (byte *)(p) #define SEGPTR(p) ((byte *)(p) + 1) #define SIGNPTR(p) ((byte *)(p) + 1) #define FLG2PTR(p) ((byte *)(p) + 1) #define OFFSPTR(p) ((word2 *)(p) + 1) #define WORD2PTR(p) ((word2 *)(p) + 1) #define INT2PTR(p) ((int2 *)(p) + 1) #define ARGCPTR(p) (word2 *)((byte *)(p) + OFFSETargcount) #define VARCPTR(p) (word2 *)((byte *)(p) + OFFSETvarcount) #define PARMSPTR(p) (truc *)((byte *)(p) + OFFSETparms) #define VARSPTR(p) (truc *)((byte *)(p) + OFFSETvars) #define STREAMPTR(p) ((struct stream *)TAddress(p)) #define STREAMTOKPTR(p) ((int2 *)(bTAddress(p) + OFFSETtok)) #define STRCELLPTR(p) ((struct strcell *)TAddress(p)) #define RECORDPTR(p) ((struct record *)TAddress(p)) #define VECSTRUCTPTR(p) \ (assert(*FLAGPTR(p) == fVECTOR || *FLAGPTR(p) == fTUPLE), \ (struct vector *)TAddress(p)) #define STRLENPTR(p) ((word2 *)(bTAddress(p) + OFFSETstrlen)) #define STRINGPTR(p) ((char *)(bTAddress(p) + OFFSETstring)) #define BYTEPTR(p) ((byte *)(bTAddress(p) + OFFSETstring)) #define VECLENPTR(p) ((word2 *)(bTAddress(p) + OFFSETveclen)) #define VECTORPTR(p) ((truc *)(bTAddress(p) + OFFSETvector)) #define PTARGETPTR(p) ((truc *)(bTAddress(p) + OFFSETfield1)) #define SIGNUMPTR(p) (bTAddress(p) + OFFSETsignum) #define BIGLENPTR(p) ((word2 *)(bTAddress(p) + OFFSETbiglen)) #define BIGNUMPTR(p) ((word2 *)(bTAddress(p) + OFFSETbigdig)) #define FLTEXPOPTR(p) ((int2 *)(bTAddress(p) + OFFSETexpo)) #define ARGCOUNTPTR(p) ((word2 *)(bTAddress(p) + OFFSETargcount)) #define OPNODEPTR(p) (truc *)bTAddress(p) #define ARG0PTR(p) ((truc *)(bTAddress(p) + OFFSETarg0)) #define ARG1PTR(p) ((truc *)(bTAddress(p) + OFFSETarg1)) #define ARGNPTR(p,n) ((truc *)(bTAddress(p) + OFFSETargn(n))) #define COMPLENPTR(p) ((word2 *)(bTAddress(p) + OFFSETcomplen)) #define FUNARGCPTR(p) ((word2 *)(bTAddress(p) + OFFSETfargc)) #define FUNVARCPTR(p) ((word2 *)(bTAddress(p) + OFFSETvarcount)) #define FUNVARSPTR(p) ((truc *)(bTAddress(p) + OFFSETvars)) #define SYMPTR(p) ((struct symbol *)SAddress(p)) #define SYMFLAGPTR(p) bSAddress(p) #define SYMBINDPTR(p) ((truc *)(bSAddress(p) + OFFSETbind)) #define SYMWBINDPTR(p) ((wtruc *)(bSAddress(p) + OFFSETbind)) #define SYMNAMEPTR(p) (*(char **)(bSAddress(p) + OFFSETname)) #define SYMCCPTR(p) ((word4 *)(bSAddress(p) + OFFSETcc)) #define SYMCC0PTR(p) ((word2 *)(bSAddress(p) + OFFSETcc)) #define SYMCC1PTR(p) ((word2 *)(bSAddress(p) + OFFSETcc1)) #define LSYMBOLPTR(p) (basePtr + *WORD2PTR(p)) #define LRSYMBOLPTR(p) (ArgStack + *WORD2PTR(p)) #define LSYMFLAGPTR(p) (byte *)(basePtr + *WORD2PTR(p)) #define STREAMtok(x) *(int2 *)(bTaddress(x) + OFFSETtok) #define STREAMpos(x) *(int2 *)(bTaddress(x) + OFFSETpos) #define STREAMfile(x) *(FILE **)(bTaddress(x) + OFFSETfile) #define SYMflag(x) *bSaddress(x) #define SYMname(x) *(char **)(bSaddress(x) + OFFSETname) #define SYMbind(x) *(truc *)(bSaddress(x) + OFFSETbind) #define SYMbind2(x) *(word2 *)(bSaddress(x) + OFFSETbind + 2) #define SYMlink(x) *(truc **)(bSaddress(x) + OFFSETlink) #define SYMcc(x) *(word4 *)(bSaddress(x) + OFFSETcc) #define SYMcc0(x) *(word2 *)(bSaddress(x) + OFFSETcc) #define SYMcc1(x) *(word2 *)(bSaddress(x) + OFFSETcc1) /*----- pushes and pops ------------------------------------------*/ #define EVALpush(obj) \ do { \ if(--evalStkPtr > workStkPtr) *evalStkPtr = (obj); \ else reset(err_evstk); \ } while(0) #define EVALpop() evalStkPtr++ #define WORKpush(obj) \ do { \ if(++workStkPtr < evalStkPtr) *workStkPtr = (obj); \ else reset(err_wrkstk); \ } while(0) #define WORKpop() workStkPtr-- #define WORKnpop(n) workStkPtr -= (n) #define WORKretr() *workStkPtr-- #define WORKnpush(n) \ do { \ if(!((workStkPtr += (n)) < evalStkPtr)) reset(err_wrkstk); \ } while(0) #define WORKspace(n) \ (workStkPtr < evalStkPtr-(n)-32 ? workStkPtr += (n) : NULL) #define ARRAYspace(n) \ (arrayStkPtr < ArrayStkCeil-(n)-8 ? arrayStkPtr += (n) : NULL) #define ARRAYmemavail() \ (ArrayStkCeil - arrayStkPtr - 8) #define ARGpush(obj) \ do { \ if(++argStkPtr < saveStkPtr) *argStkPtr = (obj); \ else reset(err_astk); \ } while(0) #define ARGretr() *argStkPtr-- #define ARGpop() argStkPtr-- #define ARGnpop(n) argStkPtr -= (n) #define SAVEPTRpush(ptr) \ do { \ if(--saveStkPtr > argStkPtr) *saveStkPtr = (truc)(ptr - ArgStack); \ else reset(err_savstk); \ } while(0) #define SAVEPTRretr() (ArgStack + (ptrdiff_t)(int4)*saveStkPtr++) #define SAVEPTRtop() (ArgStack + (ptrdiff_t)(int4)*saveStkPtr) #define SAVEspace(n) \ (saveStkPtr > argStkPtr+(n) ? saveStkPtr -= (n) : NULL) #define SAVEnpop(n) saveStkPtr += (n) #define PARSpush(obj) \ do { \ if(++argStkPtr < saveStkPtr) *argStkPtr = (obj); \ else reset(err_pstk); \ } while(0) #define PARSpop() argStkPtr-- #define PARSnpop(n) argStkPtr -= (n) #define PARSretr() *argStkPtr-- /*--------------------- external declarations -----------------------*/ #ifdef Win32GUI #include "ariwin.h" #endif #ifdef GtK #include "gnariwin.h" #endif /* errtext.c */ extern char *err_funest, *err_funame, *err_call, *err_2ident, *err_type, *err_btype, *err_mism, *err_synt, *err_args, *err_pars, *err_parl, *err_varl, *err_unvar, *err_memory, *err_2large, *err_memev, *err_garb, *err_evstk, *err_wrkstk, *err_astk, *err_savstk, *err_pstk, *err_imp, *err_case, *err_rec, *err_intr, *err_rparen, *err_0rparen, *err_0lparen, *err_0brace, *err_0rbrack, *err_brstr, *err_bchar, *err_inadm, *err_stkv, *err_stke, *err_stkbig, *err_nil, *err_vpoint, *err_filv, *err_outf, *err_tout, *err_bout, *err_inpf, *err_tinp, *err_binp, *err_then, *err_end, *err_ovfl, *err_div, *err_2big, *err_float, *err_bool, *err_int, *err_intt, *err_fix, *err_pfix, *err_pint, *err_p0int, *err_p4int, *err_odd, *err_oddprim, *err_char, *err_chr, *err_2long, *err_n2long, *err_iovfl, *err_num, *err_pnum, *err_p0num, *err_intvar, *err_pbase, *err_range, *err_irange, *err_var, *err_lval, *err_vsym, *err_vasym, *err_sym, *err_gsym, *err_sym2, *err_buf, *err_str, *err_bystr, *err_vbystr, *err_arr, *err_syarr, *err_sarr, *err_vect, *err_field, *err_open, *err_bltin, *err_ubound, *err_ufunc; /* alloc.c */ extern void inialloc (void); extern int memalloc (int mem); extern void dealloc (void); extern void resetarr (void); extern int initend (void); extern int tempfree (int flg); extern int inpack (truc obj, truc pack); extern char *stringalloc (unsigned int size); extern unsigned getblocksize (void); extern size_t new0 (unsigned int size); extern truc newobj (int flg, unsigned int size, trucptr *ptraddr); extern truc new0obj (int flg, unsigned int size, trucptr *ptraddr); extern unsigned obj4size (int type, truc *ptr); extern void cpy4arr (truc *ptr1, unsigned len, truc *ptr2); extern size_t hashtabSize, aribufSize, auxbufSize, scrbufSize; extern truc *Symbol; extern truc *Memory[]; extern trucptr *Symtab; extern truc *ArrayStack, *ArrayStkCeil, *arrayStkPtr; extern truc *WorkStack, *evalStkPtr, *workStkPtr; extern truc *ArgStack, *argStkPtr, *saveStkPtr; extern truc *basePtr; extern word2 *AriBuf, *AriScratch, *AuxBuf, *PrimTab; /* array.c */ extern void iniarray (void); extern void iniargv (int argc, char *argv[]); extern int stringsplit (char *str, char *trenn, word2 *offsets); extern truc arrassign (truc *arr, truc obj); extern truc subarrassign (truc *arr, truc obj); extern void sortarr (truc *arr, unsigned len, ifuntt cmpfun); extern int bytestraddr (truc *ptr, truc **ppbstr, byte **ppch, unsigned *plen); extern truc recfassign (truc *rptr, truc field, truc obj); extern truc fullrecassign (truc *rptr, truc obj); extern truc Pdispose (truc *ptr); extern truc arr_sym, subarrsym, arraysym; extern truc stringsym, charsym, bitvecsym, stacksym; extern truc bstringsym, bstr_sym, str_sym; extern truc mkstrsym, mkbstrsym, mkarrsym, vectorsym, pairsym; extern truc recordsym, mkrecsym, rec_sym, pointrsym, derefsym; extern truc nullstring, nullbstring; extern truc ofsym; /* arith.c: */ extern void iniarith (void); extern truc addints (truc *ptr, int minflg); extern unsigned random2 (unsigned u); extern unsigned random4 (unsigned u); extern int cmpnums (truc *ptr1, truc *ptr2, int type); extern truc scalintvec (truc *ptr1, truc *ptr2); extern truc integsym, int_sym, realsym; extern truc zero, constone, flt0zero; extern truc sfloatsym, dfloatsym, lfloatsym; extern truc plussym, minussym, uminsym, divsym, modsym, divfsym, timessym, powersym; extern truc ariltsym, arigtsym, arilesym, arigesym, arieqsym, arinesym; extern long maxfltex, maxdecex, exprange; /* aritx.c */ extern void iniaritx (void); extern int prime16 (unsigned u); extern int prime32 (word4 u); extern unsigned fact16 (word4 u); extern unsigned trialdiv (word2 *x, int n, unsigned u0, unsigned u1); extern int jac (unsigned x, unsigned y); extern int jacobi (int sign, word2 *x, int n, word2 *y, int m, word2 *hilf); extern int rabtest (word2 *x, int n, word2 *aux); extern int nextprime32 (word4 u, word2 *x); extern int pemult (word2 *x, int n, word2 *ex, int exlen, word2 *aa, int alen, word2 *mm, int modlen, word2 *z, word2 *hilf); extern int modinverse (word2 *x, int n, word2 *y, int m, word2 *zz, word2 *hilf); extern int modinv (int x, int mm); extern int modpower (word2 *x, int n, word2 *ex, int exlen, word2 *mm, int modlen, word2 *p, word2 *hilf); extern unsigned modpow (unsigned x, unsigned n, unsigned mm); extern truc modpowsym; /* arity.c */ extern void iniarity (void); extern void workmess (void); extern void tick (int c); extern int showvect (FILE *f, word2 *xx, int len); /* aritz.c */ extern void iniaritz (void); extern truc gf2nzero, gf2none, gf2nintsym, gf2n_sym; extern truc polmultsym, polNmultsym, polmodsym, polNmodsym, poldivsym, polNdivsym; extern truc addgf2ns (truc *ptr); extern truc multgf2ns (truc *ptr); extern truc divgf2ns (truc *ptr); extern truc exptgf2n (truc *ptr); extern int fpSqrt (word2 *pp, int plen, word2 *aa, int alen, word2 *zz, word2 *hilf); extern int fp2Sqrt (word2 *pp, int plen, word2 *aa, int alen, word2 *zz, word2 *hilf); extern unsigned fp_sqrt (unsigned p, unsigned a); /* aritaux.c */ extern int FltPrec[]; extern int MaxFltLevel; extern int setfltprec (int prec); extern int deffltprec (void); extern int maxfltprec (void); extern int fltprec (int type); extern int fltpreccode (int prec); extern int refnumtrunc (int prec, truc *ptr, numdata *nptr); extern int getnumtrunc (int prec, truc *ptr, numdata *nptr); extern int getnumalign (int prec, truc *ptr, numdata *nptr); extern int alignfloat (int prec, numdata *nptr); extern int alignfix (int prec, numdata *nptr); extern void adjustoffs (numdata *npt1, numdata *npt2); extern int normfloat (int prec, numdata *nptr); extern int multtrunc (int prec, numdata *npt1, numdata *npt2, word2 *hilf); extern int divtrunc (int prec, numdata *npt1, numdata *npt2, word2 *hilf); extern int pwrtrunc (int prec, unsigned base, unsigned a, numdata *nptr, word2 *hilf); extern int float2bcd (int places, truc *p, numdata *nptr, word2 *hilf); extern int roundbcd (int prec, numdata *nptr); extern int flodec2bin (int prec, numdata *nptr, word2 *hilf); extern void int2numdat (int x, numdata *nptr); extern void cpynumdat (numdata *npt1, numdata *npt2); extern int numposneg (truc *ptr); extern truc wipesign (truc *ptr); extern truc changesign (truc *ptr); extern long intretr (truc *ptr); extern int bigref (truc *ptr, word2 **xp, int *sp); extern int bigretr (truc *ptr, word2 *x, int *sp); extern int twocretr (truc *ptr, word2 *x); extern int and2arr (word2 *x, int n, word2 *y, int m); extern int or2arr (word2 *x, int n, word2 *y, int m); extern int xor2arr (word2 *x, int n, word2 *y, int m); extern int xorbitvec (word2 *x, int n, word2 *y, int m); extern long bit_length (word2 *x, int n); extern int chkintnz (truc sym, truc *ptr); extern int chkints (truc sym, truc *argptr, int n); extern int chkint (truc sym, truc *ptr); extern int chkintt (truc sym, truc *ptr); extern int chknums (truc sym, truc *argptr, int n); extern int chknum (truc sym, truc *ptr); extern int chkintvec (truc sym, truc *vptr); extern int chknumvec (truc sym, truc *vptr); /* arito386.asm */ #ifdef M_3264 extern int mult4arr (word2 *x, int n, word4 a, word2 *y); extern int div4arr (word2 *x, int n, word4 a, word4 *restptr); extern word4 mod4arr (word2 *x, int n, word4 a); #endif /* aritool0.c */ extern int multarr (word2 *x, int n, unsigned a, word2 *y); extern int divarr (word2 *x, int n, unsigned a, word2 *restptr); extern unsigned modarr (word2 *x, int n, unsigned a); extern int sumarr (word2 *x, int n, word2 *y); extern int diffarr (word2 *x, int n, word2 *y); extern int diff1arr (word2 *x, int n, word2 *y); extern int incarr (word2 *x, int n, unsigned a); extern int decarr (word2 *x, int n, unsigned a); extern void cpyarr (word2 *x, int n, word2 *y); extern void cpyarr1 (word2 *x, int n, word2 *y); extern int cmparr (word2 *x, int n, word2 *y, int m); extern int shrarr (word2 *x, int n, int k); extern int shlarr (word2 *x, int n, int k); extern void setarr (word2 *x, int n, unsigned a); extern void notarr (word2 *x, int n); extern void andarr (word2 *x, int n, word2 *y); extern void orarr (word2 *x, int n, word2 *y); extern void xorarr (word2 *x, int n, word2 *y); extern unsigned int2bcd (unsigned x); extern unsigned bcd2int (unsigned x); extern int big2bcd (word2 *x, int n, word2 *y); extern int long2big (word4 u, word2 *x); extern word4 big2long (word2 *x, int n); extern word4 intsqrt (word4 u); extern int bitlen (unsigned x); extern int niblen (unsigned x); extern int bitcount (unsigned u); /* aritools.c */ extern int shiftarr (word2 *x, int n, int sh); extern int lshiftarr (word2 *x, int n, long sh); extern int addarr (word2 *x, int n, word2 *y, int m); extern int subarr (word2 *x, int n, word2 *y, int m); extern int sub1arr (word2 *x, int n, word2 *y, int m); extern int addsarr (word2 *x, int n, int sign1, word2 *y, int m, int sign2, int *psign); extern int multbig (word2 *x, int n, word2 *y, int m, word2 *z, word2 *hilf); extern int divbig (word2 *x, int n, word2 *y, int m, word2 *quot, int *rlenptr, word2 *hilf); extern int modbig (word2 *x, int n, word2 *y, int m, word2 *hilf); extern int modnegbig (word2 *x, int n, word2 *y, int m, word2 *hilf); extern int modmultbig (word2 *xx, int xlen, word2 *yy, int ylen, word2 *mm, int mlen, word2 *zz, word2 *hilf); extern int multfix (int prec, word2 *x, int n, word2 *y, int m, word2 *z, word2 *hilf); extern int divfix (int prec, word2 *x, int n, word2 *y, int m, word2 *z, word2 *hilf); extern unsigned shortgcd (unsigned x, unsigned y); extern int biggcd (word2 *x, int n, word2 *y, int m, word2 *hilf); extern int power (word2 *x, int n, unsigned a, word2 *p, word2 *temp, word2 *hilf); extern int bigsqrt (word2 *x, int n, word2 *z, int *rlenptr, word2 *temp); extern int lbitlen (word4 x); extern int bcd2big (word2 *x, int n, word2 *y); extern int str2int (char *str, int *panz); extern int str2big (char *str, word2 *arr, word2 *hilf); extern int bcd2str (word2 *arr, int n, char *str); extern int big2xstr (word2 *arr, int n, char *str); extern int digval (int ch); extern int xstr2big (char *str, word2 *arr); extern int ostr2big (char *str, word2 *arr); extern int bstr2big (char *str, word2 *arr); extern int nibdigit (word2 *arr, int k); extern int nibndigit (int n, word2 *arr, long k); extern int nibascii (word2 *arr, int k); extern int hexascii (int n); extern int shiftbcd (word2 *arr, int n, int k); extern int incbcd (word2 *x, int n, unsigned a); /* analysis.c */ extern void inianalys (void); extern int lognum (int prec, numdata *nptr, word2 *hilf); extern int expnum (int prec, numdata *nptr, word2 *hilf); /* eval.c: */ extern void inieval (void); extern truc eval (truc *ptr); extern truc ufunapply (truc *fun, truc *arr, int n); extern truc arreval (truc *arr, int n); /* file.c */ extern void inifile (void); extern int fnextens (char *str, char *name, char *extens); extern int issepdir (int ch); extern int isoutfile (truc *strom, int mode); extern int isinpfile (truc *strom, int mode); extern int loadaux (char *str, int verb, char *skipto); extern long filelen (truc *ptr); extern char *ariExtens; extern truc filesym, eofsym; extern truc tstdout, tstdin, tstderr; /* control.c: */ extern void inicont (void); extern int is_lval (truc *ptr); extern int Lvaladdr (truc *ptr, trucptr *pvptr); extern truc Lvalassign (truc *ptr, truc obj); extern truc Swhile (void); extern truc Sfor (void); extern void Sifaux (void); extern truc Sexit (void); extern truc brkerr (void); extern truc Lconsteval (truc *ptr); extern int Lconstini (truc consts); extern truc unbindsym (truc *ptr); extern truc unbinduser (void); extern truc exitsym, exitfun, ret_sym, retsym; extern truc lpbrksym, lpbrkfun, lpcontsym, lpcontfun; extern truc equalsym, nequalsym; extern truc funcsym, procsym, beginsym, endsym; extern truc extrnsym, constsym, typesym; extern truc varsym, var_sym, inivarsym; extern truc whilesym, dosym, ifsym, thensym, elsifsym, elsesym; extern truc forsym, tosym, bysym; extern truc not_sym, notsym; extern truc *brkbindPtr, *brkmodePtr; extern truc breaksym, errsym, nullsym, voidsym; extern truc contsym, contnsym; extern truc assignsym; extern truc boolsym, truesym, falsesym, true, false, nil; extern truc usersym, arisym, symbsym; /* mainloop.c */ #ifdef DTRACE extern FILE *DTraceF; extern int DTraceWrite(char *mess); extern char DTraceZeile[80]; #endif extern truc helpsym; extern truc apathsym; extern truc *res1Ptr, *res2Ptr, *res3Ptr; extern int Unterbrech; extern int error (truc source, char *message, truc obj); extern void setinterrupt (int flg); extern void reset (char *message); extern void faterr (char *mess); extern int findfile (char *paths, char *fnam, char *buf); extern int findarifile (char *name, char *buf); #ifdef DOSorUNiX extern void ctrlcreset (int sig); #endif #ifdef MYFUN extern void inimyfun (void); #endif /* mem0.c */ extern truc *Taddress (truc x); extern truc *TAddress (truc *p); extern truc *Saddress (truc x); extern truc *SAddress (truc *p); extern int Tflag (truc x); extern int Symflag (truc x); /* parser.c */ extern void iniparse (void); extern truc tread (truc *strom, int mode); extern void clearcompile (void); extern truc parserrsym; /* scanner.c */ extern void iniscan (void); extern int nexttok (truc *strom, int skip); extern int curtok (truc *strom); extern int fltreadprec (void); extern int skipeoltok (truc *strom); extern int isalfa (int ch); extern int isdigalfa (int ch); extern int isdecdigit (int ch); extern int ishexdigit (int ch); extern int isoctdigit (int ch); extern int isbindigit (int ch); extern int toupcase (int ch); extern int tolowcase (int ch); extern char *trimblanks (char *str, int mode); extern int rerror (truc sym1, char *mess, truc sym2); extern numdata Curnum; extern char *StrBuf; /* string buffer */ extern char *SymBuf; /* buffer for symbol names */ extern truc Curop; /* currently processed operator */ /* print.c */ extern void iniprint (int cols); extern int logout (int ch); extern void strlogout (char *str); extern void closelog (void); extern void flushlog (void); extern int setprnprec (int prec); extern void tprint (truc strom, truc obj); extern int strcopy (char *tostr, char *fromstr); extern int strncopy (char *tostr, char *fromstr, int maxlen); extern int fprintstr (truc strom, char *str); extern void fprintline (truc strom, char *str); extern void fnewline (truc strom); extern void ffreshline (truc strom); extern void flinepos0 (truc strom); extern wtruc strcast (char *str); extern wtruc intcast (long x); extern int s1form (char *buf, char *fmt, wtruc dat); extern int s2form (char *buf, char *fmt, wtruc dat1, wtruc dat2); extern truc writesym, writlnsym, formatsym; extern truc transcsym; extern char OutBuf[]; extern int Log_on; /* storage.c */ extern void inistore (void); extern truc *nextsymptr (int i); extern truc symbobj (truc *ptr); extern int lookupsym (char *name, truc *pobj); extern truc mksym (char *name, int *sflgptr); extern truc scratch (char *name); extern truc newselfsym (char *name, int flg); extern truc newreflsym (char *name, int flg); extern truc newintsym (char *name, int flg, wtruc bind); extern int tokenvalue (truc op); extern truc newsym (char *name, int flg, truc bind); extern truc newsymsig (char *name, int flg, wtruc bind, int sig); extern truc new0symsig (char *name, int flg, wtruc bind, int sig); extern truc mkcopy (truc *x); extern truc mkcopy0 (truc *x); extern truc mkarrcopy (truc *x); extern truc mkinum (long n); extern truc mkarr2 (unsigned w0, unsigned w1); extern truc mklocsym (int flg, unsigned u); extern truc mkfixnum (unsigned n); extern truc mksfixnum (int n); extern truc mkint (int sign, word2 *arr, int len); extern truc mkgf2n (word2 *arr, int len); extern truc mk0gf2n (word2 *arr, int len); extern truc mkfloat (int prec, numdata *nptr); extern truc fltzero (int prec); extern truc mk0float (numdata *nptr); extern truc mkchar (int ch); extern truc mkbstr (byte *arr, unsigned len); extern truc mkstr (char *str); extern truc mkstr0 (unsigned len); extern truc mkbstr0 (unsigned len); extern truc mknullstr (void); extern truc mknullbstr (void); extern truc mkvect0 (unsigned len); extern truc mkrecord (int flg, truc *ptr, unsigned len); extern truc mkstack (void); extern truc mkstream (FILE *file, int mode); extern truc mk0stream (FILE *file, int mode); extern truc mk0fun (truc op); extern truc mkpair (int flg, truc sym1, truc sym2); extern truc mkunode (truc op); extern truc mkbnode (truc op); extern truc mkspecnode (truc fun, truc *argptr, int k); extern truc mkfunode (truc fun, int n); extern truc mkfundef (int argc, int argoptc, int varc); extern truc mkntuple (int flg, truc *arr, int n); extern truc mkcompnode (int flg, int n); /* terminal.c */ extern void initerm (void); extern void inputprompt (void); extern void dumpinput (void); extern char *treadline (void); extern void historyout (int flg); extern truc historsym, savinsym, bufovflsym; /* sysdep.c */ extern void stacklimit (void); extern long stkcheck (void); extern long timer (void); extern long datetime (int tim[6]); extern int sysrand (void); extern void prologue (void); extern int epilogue (void); extern char *getworkdir (void); extern int setworkdir (char *pfad); #ifdef ATARIST extern int VDI_handle; #endif /* syntchk.c */ extern void inisyntchk (void); extern int chknargs (truc fun, int n); extern int s_dum, s_0, s_01, s_02, s_0u, s_1, s_1u, s_12, s_bV, s_rr, s_vr, s_ii, s_iI, s_bs, s_nv, s_rrr, s_iii, s_12ii, s_12rn, s_13, s_14, s_2, s_23, s_3, s_0uii, s_iiii, s_4, s_Viiii, s_iiiII; #define NARGS_FALSE 0 #define NARGS_OK 1 #define NARGS_VAR 255 /**************************************************************************/ aribas165b/src/control.c0000644000076600000240000010451214660570650014215 0ustar ottostaff/****************************************************************/ /* file control.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ #define TYPEIDENT /* ** control.c ** function definition, logical and control functions ** ** date of last change ** 1995-02-22: lpbrksym ** 1995-03-15: const ** 1995-03-20: changed make_unbound ** 1995-03-31: pointer ** 1997-04-22: type symbol, reorg (newintsym), changed Sfor ** 1997-08-18: removed bug (discovered by M.Zimmer, Leipzig) in Sfor ** 1998-01-17: small change in Sfor (regarding toolong) ** 1998-10-07: continue statement ** 1999-06-21: make_unbound(user) ** 2002-03-27: small change in Lvalassign, new function is_lval() ** 2002-04-04: simultaneous assignment (x1,...,xn) := (val1,...,valn) ** 2002-04-27: gmtime ** 2003-02-28: case fGF2NINT in nulltest() ** 2004-06-20: function type_ident ** 2004-10-30: for-loop can now do more than 2**32 iterations */ #include "common.h" PUBLIC void inicont (void); PUBLIC int is_lval (truc *ptr); PUBLIC int Lvaladdr (truc *ptr, trucptr *pvptr); PUBLIC truc Lvalassign (truc *ptr, truc obj); PUBLIC truc Swhile (void); PUBLIC truc Sfor (void); PUBLIC void Sifaux (void); PUBLIC truc Sexit (void); PUBLIC truc brkerr (void); PUBLIC truc Lconsteval (truc *ptr); PUBLIC int Lconstini (truc consts); PUBLIC truc unbindsym (truc *ptr); PUBLIC truc unbinduser (void); PUBLIC truc boolsym; PUBLIC truc truesym, falsesym, true, false, nil; PUBLIC truc equalsym, nequalsym; PUBLIC truc exitsym, exitfun, lpbrksym, lpbrkfun, lpcontsym, lpcontfun; PUBLIC truc whilesym, dosym, ifsym, thensym, elsifsym, elsesym; PUBLIC truc forsym, tosym, bysym; PUBLIC truc constsym, varsym, var_sym, inivarsym, typesym; PUBLIC truc not_sym, notsym; PUBLIC truc voidsym, nullsym; PUBLIC truc breaksym, contsym, contnsym, errsym; PUBLIC truc retsym, ret_sym; PUBLIC truc assignsym; PUBLIC truc arisym, usersym; PUBLIC truc symbsym; PUBLIC truc funcsym, procsym; PUBLIC truc extrnsym; PUBLIC truc beginsym, endsym; PUBLIC truc *brkbindPtr, *brkmodePtr; /*--------------------------------------------------*/ PRIVATE truc symbolssym; PRIVATE truc timersym, gmtimsym; PRIVATE truc mkunbdsym; PRIVATE truc andsym, orsym; PRIVATE truc *constbindPtr; PRIVATE truc Fequal (void); PRIVATE truc Fnequal (void); PRIVATE int equal (truc *ptr1, truc *ptr2); PRIVATE truc Fnot (void); PRIVATE truc Sand (void); PRIVATE truc Sor (void); PRIVATE int nulltest (truc obj); PRIVATE truc Sinivars (void); PRIVATE truc Svarparm (void); PRIVATE truc Sassign (void); PRIVATE int symbaddr (truc *ptr, trucptr *pvptr); PRIVATE int increment (word2 *x, int n, int *signptr, word2 *inc, int inclen, int s); PRIVATE truc Freturn (void); PRIVATE truc Slpbreak (void); PRIVATE truc Slpcont (void); PRIVATE truc Stimer (void); PRIVATE truc Fgmtime (int argn); PRIVATE truc Smkunbound (void); PRIVATE truc Fsymbols (int argn); PRIVATE int symbcmp (truc *ptr1, truc *ptr2); #ifdef TYPEIDENT PRIVATE truc typeidsym; PRIVATE truc Ftypeident (void); PRIVATE int typevalue (truc symb); #endif /*----------------------------------------------------------------------*/ PUBLIC void inicont() { truc temp; truc and_sym, or_sym, const_sym; variant v; v.pp.b0 = fBOOL; v.pp.b1 = 0; v.pp.ww = 1; true = v.xx; v.pp.ww = 0; false = v.xx; boolsym = newsym("boolean", sTYPESPEC, false); voidsym = newselfsym("", sINTERNAL); nullsym = newselfsym("", sINTERNAL); contsym = newselfsym("cont", sINTERNAL); contnsym = newselfsym("contn",sINTERNAL); errsym = newselfsym("error",sINTERNAL); exitsym = newsym("exit", sPARSAUX, nullsym); temp = newintsym("exit",sSBINARY, (wtruc)Sexit); exitfun = mk0fun(temp); lpbrksym = newsym("break", sPARSAUX, nullsym); temp = newintsym("break",sSBINARY, (wtruc)Slpbreak); lpbrkfun = mk0fun(temp); lpcontsym = newsym("continue", sPARSAUX, nullsym); temp = newintsym("continue",sSBINARY, (wtruc)Slpcont); lpcontfun = mk0fun(temp); breaksym = newsym("$break", sINTERNVAR, voidsym); brkbindPtr = SYMBINDPTR(&breaksym); brkmodePtr = (truc *)SYMCCPTR(&breaksym); *brkmodePtr = breaksym; equalsym = newintsym("=", sFBINARY, (wtruc)Fequal); nequalsym = newintsym("/=", sFBINARY, (wtruc)Fnequal); assignsym = newintsym(":= ", sSBINARY, (wtruc)Sassign); funcsym = newsym("function", sPARSAUX, nullsym); procsym = newsym("procedure",sPARSAUX, nullsym); extrnsym = newsym("external", sDELIM, nullsym); varsym = newsym("var", sPARSAUX, nullsym); var_sym = newintsym("_var", sSBINARY,(wtruc)Svarparm); inivarsym = newintsym("var", sSBINARY,(wtruc)Sinivars); constsym = newsym("const", sPARSAUX, nullsym); const_sym = newsym("$const", sINTERNVAR, voidsym); constbindPtr = SYMBINDPTR(&const_sym); typesym = newsym("type", sPARSAUX, nullsym); whilesym = newsym("while", sPARSAUX, nullsym); forsym = newsym("for", sPARSAUX, nullsym); ifsym = newsym("if", sPARSAUX, nullsym); tosym = newsym("to", sDELIM, nullsym); bysym = newsym("by", sDELIM, nullsym); dosym = newsym("do", sDELIM, nullsym); thensym = newsym("then", sDELIM, nullsym); elsifsym = newsym("elsif", sDELIM, nullsym); elsesym = newsym("else", sDELIM, nullsym); beginsym = newsym("begin", sDELIM, nullsym); endsym = newsym("end", sDELIM, nullsym); not_sym = newintsym("not",sFBINARY, (wtruc)Fnot); notsym = newsym("not", sPARSAUX, not_sym); ret_sym = newintsym("return",sFBINARY, (wtruc)Freturn); retsym = newsym("return", sPARSAUX, ret_sym); and_sym = newintsym("and",sSBINARY, (wtruc)Sand); andsym = newsym("and", sINFIX, and_sym); SYMcc1(andsym) = ANDTOK; or_sym = newintsym("or", sSBINARY, (wtruc)Sor); orsym = newsym("or", sINFIX, or_sym); SYMcc1(orsym) = ORTOK; truesym = newsym("true", sSCONSTANT, true); falsesym = newsym("false", sSCONSTANT, false); nil = newreflsym("nil", sSCONSTANT); arisym = newreflsym("aribas", sSYSSYMBOL); usersym = newreflsym("user", sSYSSYMBOL); #ifdef DEVEL symbsym = newreflsym("symbol", sTYPESPEC); #else symbsym = nullsym; #endif timersym = newsymsig("timer", sSBINARY, (wtruc)Stimer, s_0); gmtimsym = newsymsig("gmtime",sFBINARY, (wtruc)Fgmtime,s_01); mkunbdsym = newsymsig("make_unbound", sSBINARY, (wtruc)Smkunbound, s_bV); symbolssym = newsymsig("symbols", sFBINARY, (wtruc)Fsymbols, s_12); #ifdef TYPEIDENT typeidsym = newsymsig("type_ident", sFBINARY, (wtruc)Ftypeident, s_1); #endif } /*----------------------------------------------------------------------*/ PRIVATE truc Fequal() { return(equal(argStkPtr-1,argStkPtr) ? true : false); } /*----------------------------------------------------------*/ PRIVATE truc Fnequal() { return(equal(argStkPtr-1,argStkPtr) ? false : true); } /*----------------------------------------------------------*/ PRIVATE int equal(ptr1,ptr2) truc *ptr1, *ptr2; { char *cpt1, *cpt2; unsigned n, i; int flg, flg2; if(*ptr1 == *ptr2) return(1); flg = *FLAGPTR(ptr1); flg2 = *FLAGPTR(ptr2); if(flg >= fFIXNUM && flg2 >= fFIXNUM) { if(flg2 > flg) flg = flg2; return(cmpnums(ptr1,ptr2,flg) ? 0 : 1); } else if(flg != flg2) { if(*ptr2 != nil && *ptr1 != nil) return(0); else if(*ptr2 == nil) { if(flg == fPOINTER && *PTARGETPTR(ptr1) == nil) return(1); } else { /* *ptr1 == nil */ if(flg2 == fPOINTER && *PTARGETPTR(ptr2) == nil) return(1); } return(0); } else switch(flg) { /* here flg == flg2 */ case fGF2NINT: return(cmpnums(ptr1,ptr2,flg) ? 0 : 1); case fSTRING: case fBYTESTRING: n = *STRLENPTR(ptr1); if(n != *STRLENPTR(ptr2)) return(0); cpt1 = STRINGPTR(ptr1); cpt2 = STRINGPTR(ptr2); for(i=0; i 0) return(false); else if(!val) return(true); else { error(notsym,err_bool,*argStkPtr); return(brkerr()); } } /*-----------------------------------------------------------*/ PRIVATE truc Sand() { truc obj; int val; obj = eval(ARG0PTR(evalStkPtr)); val = nulltest(obj); if(!val) return(false); else if(val > 0) { obj = eval(ARG1PTR(evalStkPtr)); val = nulltest(obj); if(!val) return(false); else if(val > 0) return(true); } error(andsym,err_bool,obj); return(brkerr()); } /*-----------------------------------------------------------*/ PRIVATE truc Sor() { truc obj; int val; obj = eval(ARG0PTR(evalStkPtr)); val = nulltest(obj); if(val > 0) return(true); else if(!val) { obj = eval(ARG1PTR(evalStkPtr)); val = nulltest(obj); if(val > 0) return(true); else if(!val) return(false); } error(orsym,err_bool,obj); return(brkerr()); } /*-----------------------------------------------------------*/ /* ** returns 0 if obj represents false, 1 if true ** returns aERROR in case of error */ PRIVATE int nulltest(obj) truc obj; { variant v; v.xx = obj; switch(v.pp.b0) { /* flag */ case fBOOL: case fFIXNUM: case fCHARACTER: return(v.pp.ww ? 1 : 0); case fBIGNUM: /* bignum is not zero */ return(1); case fGF2NINT: return (obj == gf2nzero ? 0 : 1); default: return(aERROR); } } /*----------------------------------------------------------*/ PRIVATE truc Sinivars() { struct symbol *sptr; truc *ptr; truc obj; int i,n; ptr = TAddress(evalStkPtr); WORKpush(ptr[1]); /* list of variables */ ARGpush(ptr[2]); /* list of initial values */ ptr = TAddress(argStkPtr); n = *WORD2PTR(ptr); /* number of variables */ for(i=1; i<=n; i++) { ptr = TAddress(argStkPtr) + i; obj = eval(ptr); ptr = TAddress(workStkPtr) + i; sptr = SYMPTR(ptr); *FLAGPTR(sptr) = sVARIABLE; sptr->bind.t = obj; } ARGpop(); WORKpop(); return(varsym); } /*-----------------------------------------------------------*/ /* ** Initialisierung der lokalen Konstanten (nach dem ** Lesen der const-Deklaration) ** Werte werden an das Symbol const_sym als fTUPLE gebunden */ PUBLIC int Lconstini(consts) truc consts; { truc *ptr; truc obj; unsigned i, n; int res = 0; if(consts == voidsym) { *constbindPtr = voidsym; return(0); } ptr = Taddress(consts); *constbindPtr = ptr[2]; ptr = TAddress(constbindPtr); n = *WORD2PTR(ptr); for(i=1; i<=n; i++) { obj = eval(++ptr); if(obj == breaksym) { res = aERROR; break; } else res = i; ptr = TAddress(constbindPtr) + i; /* ptr must be evaluated again, since gc may have occurred */ *ptr = obj; } return(res); } /*-----------------------------------------------------------*/ /* ** bestimmt den Wert einer lokalen Konstanten ** (waehrend des Compilierens einer benutzerdefinierten Funktion) */ PUBLIC truc Lconsteval(ptr) truc *ptr; { truc *vec; unsigned n,len; n = *WORD2PTR(ptr); if(*FLAGPTR(constbindPtr) == fTUPLE) { len = *VECLENPTR(constbindPtr); if(n < len) { vec = VECTORPTR(constbindPtr); return(vec[n]); } } error(constsym,err_case,mkfixnum(n)); return(zero); } /*-----------------------------------------------------------*/ PRIVATE truc Svarparm() { truc obj; obj = eval(ARG0PTR(evalStkPtr)); return(obj); } /*-----------------------------------------------------------*/ PRIVATE truc Sassign() { truc obj; int flg; obj = eval(ARG1PTR(evalStkPtr)); flg = Tflag(obj); if(flg <= fVECTLIKE1 && flg >= fRECORD) { WORKpush(obj); if(flg < fCONSTLIT) { /* fRECORD or fVECTOR */ obj = mkarrcopy(workStkPtr); } else { /* flg == fSTRING || flg == fBYTESTRING */ obj = mkcopy(workStkPtr); } WORKpop(); } return(Lvalassign(ARG0PTR(evalStkPtr),obj)); } /*-----------------------------------------------------------*/ /* ** Moegliche lvals sind entweder Symbole mit den flags ** fSYMBOL (globales Symbol) ** fLSYMBOL (lokales Symbol) ** fRSYMBOL (Referenz auf Symbol [global oder lokal] bei var-Parametern) ** sowie Array-Elemente, Sub-Arrays, Record-Felder, Pointer-Referenzen ** ** In *pvptr wird entweder ein Pointer auf die bind-Zelle eines Symbols ** abgelegt (Rueckgebewert vBOUND oder vUNBOUND) ** oder ein Pointer ptr auf eine Funktion zur Beschreibung des lvals: ** Rueckgabewert vARRELE: ** ptr[0] = arr_sym, ptr[1] = Array, ptr[2] = Index ** vSUBARRAY: ** ptr[0] = subarrsym, ptr[1] = Array, ptr[2] = Paar mit Subarray-Grenzen ** vRECFIELD: ** ptr[0] = rec_sym, ptr[1] = Record, ptr[2] = field ** vPOINTREF: ** ptr[0] = derefsym, ptr[1] = Pointer ** vVECTOR: ** ptr[0] = vectorsym, ptr[1] = len, ptr[2] = ele0, ptr[3] = ele1, .. ** Die Argumente in ptr[1] bzw. ptr[2] sind jeweils unausgewertet. */ PUBLIC int Lvaladdr(ptr,pvptr) truc *ptr; trucptr *pvptr; { int flag; flag = *FLAGPTR(ptr); if(flag == fLSYMBOL) { *pvptr = LSYMBOLPTR(ptr); return(vBOUND); } else if(flag == fSYMBOL) { return(symbaddr(ptr,pvptr)); } else if(flag == fRSYMBOL) { ptr = LSYMBOLPTR(ptr); if((flag = *FLAGPTR(ptr)) == fSYMBOL) return(symbaddr(ptr,pvptr)); else if(flag == fLRSYMBOL) { *pvptr = LRSYMBOLPTR(ptr); return(vBOUND); } /* else fall through */ } if(flag >= fSPECIAL1 && flag <= fBUILTINn) { /* array access or record access or pointer reference or vector*/ *pvptr = ptr = TAddress(ptr); if(*ptr == arr_sym) { return(vARRELE); } else if(*ptr == subarrsym) { return(vSUBARRAY); } else if(*ptr == rec_sym) { return(vRECFIELD); } else if(*ptr == derefsym) { return(vPOINTREF); } else if(*ptr == vectorsym) { return(vVECTOR); } } /* else aERROR */ *pvptr = NULL; return(aERROR); } /*-----------------------------------------------------------*/ /* ** stripped down version of Lvaladdr */ PUBLIC int is_lval(ptr) truc *ptr; { struct symbol *sptr; int flag; flag = *FLAGPTR(ptr); if(flag == fLSYMBOL) { return(vBOUND); } else if(flag == fSYMBOL) { goto symbol; } else if(flag == fRSYMBOL) { ptr = LSYMBOLPTR(ptr); if((flag = *FLAGPTR(ptr)) == fSYMBOL) goto symbol; else if(flag == fLRSYMBOL) { return(vBOUND); } /* else fall through */ } if(flag == fBUILTIN2 || flag == fSPECIAL2 || flag == fSPECIAL1) { /* array access or record access or pointer reference */ ptr = TAddress(ptr); if(*ptr == arr_sym) { return(vARRELE); } else if(*ptr == subarrsym) { return(vSUBARRAY); } else if(*ptr == rec_sym) { return(vRECFIELD); } else if(*ptr == derefsym) { return(vPOINTREF); } /* else fall through */ } /* else aERROR */ return(aERROR); symbol: sptr = SYMPTR(ptr); switch(*FLAGPTR(sptr)) { case sUNBOUND: return(vUNBOUND); case sVARIABLE: return(vBOUND); case sCONSTANT: case sSCONSTANT: return(vCONST); default: break; } return(aERROR); } /*-----------------------------------------------------------*/ /* ** Legt in *pvptr die Adresse, in der der Wert des Symbols ** gespeichert ist, falls es sich um eine Variable oder ein ** ungebundenes Symbol handelt ** Return-Wert: ** vBOUND, falls Bindung vorhanden, ** vUNBOUND, falls noch ungebunden, ** vCONST, falls Konstante ** aERROR falls keine Variable */ PRIVATE int symbaddr(ptr,pvptr) truc *ptr; trucptr *pvptr; { struct symbol *sptr; sptr = SYMPTR(ptr); switch(*FLAGPTR(sptr)) { case sUNBOUND: *FLAGPTR(sptr) = sVARIABLE; *pvptr = &(sptr->bind.t); return(vUNBOUND); case sVARIABLE: *pvptr = &(sptr->bind.t); return(vBOUND); case sCONSTANT: case sSCONSTANT: *pvptr = NULL; return(vCONST); default: *pvptr = NULL; return(aERROR); } } /*-----------------------------------------------------------*/ PUBLIC truc Lvalassign(ptr,obj) truc *ptr; truc obj; { truc *vptr; truc *ptr1, *work0ptr; truc ele; int flg, ret, len, k; if(obj == nil) return(Pdispose(ptr)); ret = Lvaladdr(ptr,&vptr); if(ret == vBOUND || ret == vUNBOUND) { flg = *FLAGPTR(vptr); switch(flg) { case fRECORD: return(fullrecassign(vptr,obj)); case fPOINTER: default: /******* type check unvollstaendig **********/ return(*vptr = obj); } } /* else */ WORKpush(obj); switch(ret) { case vARRELE: case vSUBARRAY: ARGpush(vptr[1]); ARGpush(vptr[2]); argStkPtr[-1] = eval(argStkPtr-1); argStkPtr[0] = eval(argStkPtr); if(ret == vARRELE) obj = arrassign(argStkPtr-1,*workStkPtr); else obj = subarrassign(argStkPtr-1,*workStkPtr); ARGnpop(2); break; case vRECFIELD: ARGpush(vptr[1]); *argStkPtr = eval(argStkPtr); obj = recfassign(argStkPtr,vptr[2],*workStkPtr); /* vptr[2] = field */ ARGpop(); break; case vPOINTREF: ARGpush(vptr[1]); *argStkPtr = eval(argStkPtr); flg = *FLAGPTR(argStkPtr); if(flg == fPOINTER) { ptr1 = TAddress(argStkPtr); if(ptr1[2] == nil) { error(assignsym,err_nil,voidsym); obj = brkerr(); } else { obj = fullrecassign(ptr1+2,*workStkPtr); } } else { obj = brkerr(); } ARGpop(); break; case vVECTOR: if(*FLAGPTR(workStkPtr) != fVECTOR) { error(assignsym,err_vect,obj); goto errexit; } len = *WORD2PTR(vptr+1); if(len != *VECLENPTR(workStkPtr)) { error(assignsym,"vectors must have same length",mkfixnum(len)); goto errexit; } work0ptr = workStkPtr; for(k=0; k 0) { for(res=voidsym, ptr=arr, i=0; ++ilen - 4; ptr = &(fptr->runvar); if((flg = *FLAGPTR(ptr)) == fSYMBOL) { sptr = SYMPTR(ptr); *FLAGPTR(sptr) = sVARIABLE; runvar = &(sptr->bind.t); } else if(flg == fLSYMBOL) { runvar = LSYMBOLPTR(ptr); } else { error(forsym,err_case,mkfixnum(flg)); return(brkerr()); } argptr0 = argStkPtr; saveptr0 = saveStkPtr; arr = workStkPtr + 1; ARGpush(fptr->inc); ARGpush(fptr->end); ARGpush(fptr->start); ptr = &(fptr->body0); for(i=0; i 2) { toolong = 1; } else { anz = big2long(AriBuf,n); if(anz < 0xFFFFFFFF) { anz++; } else { toolong = 1; } } if(toolong) { zaehler = (word2*)SAVEspace(n/2+2); if(zaehler) { cpyarr(AriBuf,n,zaehler); zlen = incarr(zaehler,n,1); } else { error(forsym,err_savstk,voidsym); goto cleanup; } } } n0 = bigref(argStkPtr,&x,&sign); /* start */ m = (n0 < inclen ? inclen : n0) + 3; slen = (m + inclen)/2 + 2; /* unit of SaveStack is word4???? */ lauf = (word2 *)SAVEspace(slen); if(lauf) { cpyarr(x,n0,lauf); inc = lauf + m; cpyarr(y,inclen,inc); } else { error(forsym,err_savstk,voidsym); goto cleanup; } if(!toolong) { while(anz) { *runvar = mkint(sign,lauf,n0); obj = arreval(arr,bodylen); if((obj == breaksym) && (*brkmodePtr != lpcontsym)) { if(*brkmodePtr != lpbrksym) res = obj; /* else res = voidsym; */ break; } n0 = increment(lauf,n0,&sign,inc,inclen,sign1); anz--; } } else { while(zlen) { *runvar = mkint(sign,lauf,n0); obj = arreval(arr,bodylen); if((obj == breaksym) && (*brkmodePtr != lpcontsym)) { if(*brkmodePtr != lpbrksym) res = obj; /* else res = voidsym; */ break; } n0 = increment(lauf,n0,&sign,inc,inclen,sign1); zlen = decarr(zaehler,zlen,1); } } cleanup: saveStkPtr = saveptr0; argStkPtr = argptr0; workStkPtr = arr - 1; return(res); } /*-----------------------------------------------------------*/ PRIVATE int increment(x,n,signptr,inc,inclen,s) word2 *x, *inc; int n, inclen; int *signptr; int s; { int cmp; if(*signptr == s) return(addarr(x,n,inc,inclen)); /* else */ cmp = cmparr(x,n,inc,inclen); if(cmp > 0) return(subarr(x,n,inc,inclen)); else if(cmp < 0) { *signptr = s; return(sub1arr(x,n,inc,inclen)); } else { *signptr = 0; return(0); } } /*-----------------------------------------------------------*/ /* ** Bestimmt in einem if-elsif-...-else-Ausdruck durch Auswertung ** der Bedingungen, welcher Zweig ausgewertet werden muss ** und legt diesen in *evalStkPtr ab */ PUBLIC void Sifaux() { truc *ptr; int val; int i, n; ptr = TAddress(evalStkPtr); n = *WORD2PTR(ptr); for(i=1; i 0) { *evalStkPtr = *ARGNPTR(evalStkPtr,i); return; } else if(val == 0) { ptr = TAddress(evalStkPtr); /* this may have been changed */ } else { /* val == aERROR */ *evalStkPtr = brkerr(); return; } } *evalStkPtr = *ARGNPTR(evalStkPtr,n-1); /* else statement */ return; } /*-----------------------------------------------------------*/ PRIVATE truc Freturn() { if((*brkbindPtr = *argStkPtr) == breaksym) *brkmodePtr = errsym; else { *brkmodePtr = retsym; } return(breaksym); } /*-----------------------------------------------------------*/ PUBLIC truc Sexit() { *brkmodePtr = exitsym; return(breaksym); } /*-----------------------------------------------------------*/ PRIVATE truc Slpbreak() { *brkmodePtr = lpbrksym; return(breaksym); } /*-----------------------------------------------------------*/ PRIVATE truc Slpcont() { *brkmodePtr = lpcontsym; return(breaksym); } /*-----------------------------------------------------------*/ PUBLIC truc brkerr() { *brkmodePtr = errsym; return(breaksym); } /*-----------------------------------------------------------*/ PRIVATE truc Stimer() { return mkinum(timer()); } /*----------------------------------------------------------*/ PRIVATE truc Fgmtime(argn) int argn; { int tim[6]; long secs; char *str; word4 x,y; secs = datetime(tim); if(argn == 1 && *argStkPtr == zero) { return mkinum(secs); } /* else */ x = tim[0] + 1900; y = tim[1] + 1; str = OutBuf; str += s2form(str,"~04D:~02D:", intcast(x),intcast(y)); x = tim[2]; y = tim[3]; str += s2form(str,"~02D:~02D:",intcast(x),intcast(y)); x = tim[4]; y = tim[5]; s2form(str,"~02D:~02D",intcast(x),intcast(y)); return mkstr(OutBuf); } /*----------------------------------------------------------*/ PRIVATE truc Smkunbound() { truc *ptr; int flg; ptr = ARG0PTR(evalStkPtr); if((flg = *FLAGPTR(ptr)) != fSYMBOL) { /** arrays of symbols? **/ error(mkunbdsym,err_gsym,(flg==fLSYMBOL ? voidsym : *ptr)); return(false); } else if(*ptr == usersym) { return(unbinduser()); } else if(*SYMFLAGPTR(ptr) >= sFBINARY) { error(mkunbdsym,err_bltin,*ptr); return(false); } else return(unbindsym(ptr)); } /*----------------------------------------------------------*/ /* ** unbind all user defined symbols */ PUBLIC truc unbinduser() { truc *ptr; truc obj; int flg; int i = 0; while((ptr = nextsymptr(i++))) { obj = symbobj(ptr); if(!inpack(obj,usersym)) continue; flg = *FLAGPTR(ptr); if(flg >= sVARIABLE && flg < sINTERNAL) { unbindsym(ptr); } else continue; } return(true); } /*----------------------------------------------------------*/ /* ** unbinds symbol *ptr ** (used also by globtypedef [file parser.c] in case of error) ** ! if *ptr is not a symbol, this may have bad consequences ! */ PUBLIC truc unbindsym(ptr) truc *ptr; { struct symbol *sptr; sptr = SYMPTR(ptr); sptr->bind.t = zero; *FLAGPTR(sptr) = sUNBOUND; return(true); } /*----------------------------------------------------------*/ PRIVATE truc Fsymbols(argn) int argn; { truc *arr, *ptr; truc vec, pack, obj; char *str; int flg; int i = 0; int count = 0; int strflag; if(argn == 2) { pack = argStkPtr[-1]; strflag = (*FLAGPTR(argStkPtr) == fSTRING ? 1 : 0); } else { pack = *argStkPtr; strflag = 0; } /*** if(pack != usersym && pack != arisym) pack = usersym; ***/ arr = workStkPtr + 1; while((ptr = nextsymptr(i++))) { obj = symbobj(ptr); if(!inpack(obj,pack)) continue; flg = *FLAGPTR(ptr); if(flg >= sVARIABLE && flg < sINTERNAL) { WORKpush(obj); count++; } else continue; } sortarr(arr,count,symbcmp); if(strflag) { for(i=0; i= 0) *ptr++ = WORKretr(); return(vec); } /*----------------------------------------------------------*/ /* ** Compare symbol names case insensitive */ PRIVATE int symbcmp(ptr1,ptr2) truc *ptr1, *ptr2; { char *str1, *str2; int ch1=0, ch2=0; /* return(strcmp(SYMNAMEPTR(ptr2),SYMNAMEPTR(ptr1))); */ str1 = SYMNAMEPTR(ptr1); str2 = SYMNAMEPTR(ptr2); while((ch1=*str1++) && (ch2=*str2++)) { ch1 = tolowcase(ch1); ch2 = tolowcase(ch2); if(ch1 != ch2) break; } return (ch2 - ch1); } /*----------------------------------------------------------*/ PRIVATE truc Ftypeident() { int flag, flg1, val; truc obj, symb; flag = *FLAGPTR(argStkPtr); if(flag==1) { flg1 = *SYMFLAGPTR(argStkPtr); switch(flg1) { case sFUNCTION: case sVFUNCTION: case sFBINARY: case sSBINARY: symb = funcsym; break; case sTYPEDEF: *argStkPtr = *SYMBINDPTR(argStkPtr); flag = *FLAGPTR(argStkPtr); goto weiter; case sPARSAUX: symb = *argStkPtr; if(symb == funcsym || symb == procsym) symb = funcsym; else symb = voidsym; break; case sTYPESPEC: symb = *argStkPtr; break; case sSCONSTANT: symb = *argStkPtr; if(symb == nil) symb = pointrsym; break; default: symb = voidsym; break; } goto ausgang; } weiter: switch(flag) { case fBOOL: symb = boolsym; break; case fFIXNUM: case fBIGNUM: symb = integsym; break; case fGF2NINT: symb = gf2nintsym; break; case fCHARACTER: symb = charsym; break; case fSTRING: symb = stringsym; break; case fBYTESTRING: symb = bstringsym; break; case fVECTOR: symb = arraysym; break; case fSTREAM: symb = filesym; break; case fSTACK: symb = stacksym; break; case fRECORD: symb = recordsym; break; case fPOINTER: symb = pointrsym; break; case fBUILTIN1: obj = *OPNODEPTR(argStkPtr); if(obj == mkrecsym) { symb = recordsym; break; } /* else fall through */ default: if ((flag & fFLTOBJ) == fFLTOBJ) symb = realsym; else symb = errsym; break; } ausgang: val = typevalue(symb); return mkinum(val); } /*----------------------------------------------------------*/ PRIVATE int typevalue(symb) truc symb; { int val; if(symb == boolsym) { val = 1; } else if(symb == integsym) { val = 2; } else if(symb == gf2nintsym) { val = 3; } else if(symb == realsym) { val = 4; } else if(symb == charsym) { val = 10; } else if(symb == stringsym) { val = 11; } else if(symb == bstringsym) { val = 12; } else if(symb == arraysym) { val = 20; } else if(symb == recordsym) { val = 21; } else if(symb == pointrsym) { val = 22; } else if(symb == stacksym) { val = 23; } else if(symb == filesym) { val = 30; } else if(symb == funcsym) { val = 40; } else if(symb == voidsym) { val = 0; } else val = -1; return val; } /*********************************************************************/ aribas165b/src/errtext.c0000644000076600000240000001306014660570650014227 0ustar ottostaff/****************************************************************/ /* file errtext.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** errtext.c ** error messages ** ** date of last change ** 1995-03-22 ** 2001-03-11: err_0brace ** 2007-08-30: err_n2long ** 2018-09-13: err_call */ char *err_funest = "nested function definition not allowed"; char *err_funame = "inadmissible function name"; char *err_2ident = "duplicate or inadmissible identifier"; char *err_synt = "syntax error"; char *err_imp = "not yet implemented"; char *err_case = "this case should not happen"; char *err_args = "incorrect number of arguments"; char *err_pars = "bad parameter(s)"; char *err_varl = "bad variable list"; char *err_parl = "bad parameter list"; char *err_unvar = "undeclared variable"; char *err_evstk = "evaluation stack overflow"; char *err_astk = "argument stack overflow"; char *err_pstk = "parse stack overflow"; char *err_savstk = "save stack overflow"; char *err_wrkstk = "work stack overflow"; char *err_memory = "memory space exhausted"; char *err_memev = "insufficient memory for evaluation"; char *err_2large = "too large piece of memory requested"; char *err_rec = "too deeply nested recursion"; char *err_intr = "user interrupt"; char *err_garb = "garbage collection failed"; char *err_pbase = "only allowed values are 2,8,10,16"; char *err_int = "integer number expected"; char *err_intt = "integer or gf2nint expected"; char *err_intvar = "integer variable expected"; char *err_odd = "odd integer expected"; char *err_oddprim = "odd prime expected"; char *err_2big = "number too big"; char *err_pint = "positive integer expected"; char *err_p0int = "non-negative integer expected"; char *err_p4int = "non-negative integer < 2**31 expected"; char *err_pfix = "non-negative integer < 2**16 expected"; char *err_fix = "integer -2**16 < x < 2**16 expected"; char *err_pnum = "positive number expected"; char *err_p0num = "non-negative number expected"; char *err_float = "float number expected"; char *err_num = "number expected"; char *err_2long = "string too long"; char *err_n2long = "file name too long"; char *err_iovfl = "input buffer overflow"; char *err_bool = "boolean or integer value expected"; char *err_div = "division by zero"; char *err_bas1 = "basis must be /= 1"; char *err_ovfl = "arithmetic overflow"; char *err_range = "argument out of range"; char *err_irange = "index out of range"; char *err_inadm = "inadmissible input"; char *err_buf = "buffer too short"; char *err_brstr = "broken string"; char *err_bystr = "byte_string expected"; char *err_vbystr = "byte_string variable expected"; char *err_str = "string expected"; char *err_strsym = "string or symbol expected"; char *err_arr = "array, string or byte_string expected"; char *err_syarr = "symbol array, string or byte_string expected"; char *err_sarr = "bad subarray indices"; char *err_vect = "vector expected"; char *err_nil = "pointer is nil"; char *err_vpoint = "pointer variable expected"; char *err_stkv = "stack variable expected"; char *err_stke = "stack is empty"; char *err_stkbig = "stack too big"; char *err_vasym = "variable argument: symbol expected"; char *err_vsym = "variable symbol expected"; char *err_lval = "lval expected"; char *err_sym = "symbol expected"; char *err_gsym = "global symbol expected"; char *err_sym2 = "non-constant symbol expected"; char *err_field = "bad field identifier"; char *err_ubound = "unbound symbol"; char *err_ufunc = "undefined function"; char *err_var = "bad variable"; char *err_call = "not a function"; char *err_open = "can't open file"; char *err_filex = "file exists already"; char *err_filv = "file variable expected"; char *err_outf = "output file expected"; char *err_tout = "text output file expected"; char *err_bout = "binary output file expected"; char *err_inpf = "input file expected"; char *err_tinp = "text input file expected"; char *err_binp = "binary input file expected"; char *err_char = "character expected"; char *err_bchar = "bad character input"; char *err_chr = "integer < 2**16 expected"; char *err_type = "invalid argument type"; char *err_btype = "bad type specification"; char *err_mism = "type mismatch"; char *err_rparen = "unexpected ')'"; char *err_0rparen = "')' expected"; char *err_0lparen = "'(' expected"; char *err_0brace = "'}' expected"; char *err_0rbrack = "']' expected"; char *err_eof = "unexpected end of file"; char *err_bltin = "built-in symbol cannot be made unbound"; /********************************************************************/ aribas165b/src/eval.c0000644000076600000240000004004414660570650013463 0ustar ottostaff/****************************************************************/ /* file eval.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** eval.c ** evaluation functions ** ** date of last change ** 1995-03-20: sSYSTEMVAR ** 1995-03-25: fRECORD ** 1995-04-14: fixed bug in eval (case optional arguments) ** 2002-06-08: bugfix in evalargs and evalvargs */ #include "common.h" #define STACKFAIL (stkcheck() < 512) /******* prototypes of exported functions ************/ PUBLIC void inieval (void); PUBLIC truc eval (truc *ptr); PUBLIC truc ufunapply (truc *fun, truc *arr, int n); PUBLIC truc arreval (truc *arr, int n); /******* module global variable *********/ PRIVATE truc evalsym; /******* prototypes of functions internal to this module *****/ PRIVATE truc eval0 (truc *ptr, int flg); PRIVATE int stkevargs (truc *ptr); PRIVATE void argvarspace (truc *argptr, int n, truc *vptr, int m); PRIVATE int evalargs (truc *argptr, int n); PRIVATE int evalvargs (truc parms, truc *argptr, int n); PRIVATE truc vsymaux (truc *argptr, unsigned depth); PRIVATE int lvarsini (truc *arr, int n); /* -------------------------------------------------------*/ PUBLIC void inieval() { evalsym = newselfsym("eval", sINTERNAL); } /* -------------------------------------------------------*/ /* ** evaluates *ptr */ PUBLIC truc eval(ptr) truc *ptr; { static struct symbol *sptr; static truc *ptr1, *ptr2; static truc obj; static truc parms; static int i, n; static int chk; static int flg; /* static, damit bei Rekursion nur einmal Speicher reserviert wird */ funptr binfun; int k; if((flg = *FLAGPTR(ptr)) >= fSELFEVAL) { return(*ptr); } else if(flg < fFUNEXPR) return(eval0(ptr,flg)); /**** at this point flg >= fFUNEXPR && flg < fSELFEVAL *****/ if(STACKFAIL) reset(err_rec); if(INTERRUPT) { setinterrupt(0); reset(err_intr); } EVALpush(*ptr); /********************/ tailnrec: if(flg <= fSPECIALn) { if(flg == fSPECIAL0) binfun = (funptr)*SYMWBINDPTR(evalStkPtr); else binfun = (funptr)*SYMWBINDPTR(TAddress(evalStkPtr)); obj = binfun(); } else if(flg <= fBUILTINn) { binfun = (funptr)*SYMWBINDPTR(TAddress(evalStkPtr)); switch(flg) { case fBUILTIN1: obj = eval(ARG0PTR(evalStkPtr)); ARGpush(obj); obj = binfun(); ARGpop(); break; case fBUILTIN2: obj = eval(ARG0PTR(evalStkPtr)); ARGpush(obj); obj = eval(ARG1PTR(evalStkPtr)); ARGpush(obj); obj = binfun(); ARGnpop(2); break; default: /* case fBUILTINn */ goto fnbineval; } } else switch(flg) { case fFUNCALL: ptr = TAddress(evalStkPtr); obj = eval0(ptr,*FLAGPTR(ptr)); /* make sure that `obj' is an fSYMBOL truc. This is to handle cases like: stderr(). x := 7; x(). */ if(Tflag(obj) != fSYMBOL) { error(obj,err_call,voidsym); obj = brkerr(); goto cleanup; } sptr = symptr(obj); flg = *FLAGPTR(sptr); if(flg == sFUNCTION || flg == sVFUNCTION) { ptr = Taddress(sptr->bind.t); /* ptr zeigt auf die Funktions-Definition */ } else if(flg == sFBINARY || flg == sSBINARY) { k = *ARGCOUNTPTR(evalStkPtr); chk = chknargs(obj,k); if(chk == NARGS_FALSE) { error(obj,err_args,voidsym); obj = brkerr(); goto cleanup; } binfun = (funptr)sptr->bind.w; if(k == 0 || ((flg==sSBINARY) && (chk==NARGS_VAR || k>=3))) { obj = binfun(); } else if(flg==sFBINARY && chk==NARGS_OK && k<=2) { if(k == 1) { obj = eval(ARG1PTR(evalStkPtr)); ARGpush(obj); obj = binfun(); ARGpop(); } else { /* k == 2 */ obj = eval(ARG1PTR(evalStkPtr)); ARGpush(obj); obj = eval(ARGNPTR(evalStkPtr,2)); ARGpush(obj); obj = binfun(); ARGnpop(2); } } else if(flg == sFBINARY) { goto fnbineval; } else { /* flg == sSBINARY && (k == 1 || k == 2) */ *evalStkPtr = mkspecnode(obj,ARG1PTR(evalStkPtr),k); obj = binfun(); } goto cleanup; } else { error(evalsym,err_ufunc,*ptr); obj = brkerr(); goto cleanup; } n = *WORD2PTR(ptr); /* number of formal function arguments */ i = *ARGCOUNTPTR(evalStkPtr); /* number of actual function arguments */ if(n != i) { if(i < n && n-i <= *FLG2PTR(ptr)) { chk = 1; } else { error(*TAddress(evalStkPtr),err_args,voidsym); obj = brkerr(); break; } } else chk = 0; SAVEPTRpush(argStkPtr); k = *VARCPTR(ptr); if(chk) { /* provide default optional arguments */ ptr1 = VECTORPTR(PARMSPTR(ptr)); argvarspace(ptr1,n,VARSPTR(ptr),k); ptr1 = SAVEPTRtop() + 1; ptr2 = ARG1PTR(evalStkPtr); while(--i >= 0) *ptr1++ = *ptr2++; } else { argvarspace(ARG1PTR(evalStkPtr),n,VARSPTR(ptr),k); } *evalStkPtr = *(ptr + OFFS4body); if(flg == sVFUNCTION) { parms = *PARMSPTR(ptr); ptr = SAVEPTRtop() + 1; n = evalvargs(parms,ptr,n); } else { ptr = SAVEPTRtop() + 1; n = evalargs(ptr,n); } SAVEPTRpush(basePtr); basePtr = ptr; if(n == aERROR || lvarsini(ptr+n,k) == aERROR) obj = brkerr(); else { obj = zero; k = *FUNARGCPTR(evalStkPtr); while(--k >= 0) { obj = eval(ARGNPTR(evalStkPtr,k)); if(obj == breaksym) { if(*brkmodePtr == retsym) { obj = *brkbindPtr; *brkbindPtr = zero; } break; } } } basePtr = SAVEPTRretr(); argStkPtr = SAVEPTRretr(); break; case fWHILEXPR: obj = Swhile(); break; case fFOREXPR: obj = Sfor(); break; case fIFEXPR: Sifaux(); flg = *FLAGPTR(evalStkPtr); if(flg != fCOMPEXPR) { obj = eval(evalStkPtr); break; } /* else fall through */ case fCOMPEXPR: obj = voidsym; k = *FUNARGCPTR(evalStkPtr); if(k == 0) goto cleanup; while(--k > 0) { /* evaluate k-1 expressions */ obj = eval(ARGNPTR(evalStkPtr,k)); if(obj == breaksym) goto cleanup; } /* tail recursion elimination */ *evalStkPtr = *ARG0PTR(evalStkPtr); flg = *FLAGPTR(evalStkPtr); if(flg >= fSELFEVAL) obj = *evalStkPtr; else if(flg < fFUNEXPR) obj = eval0(evalStkPtr,flg); else goto tailnrec; break; default: error(evalsym,err_case,mkfixnum(flg)); obj = brkerr(); } goto cleanup; fnbineval: SAVEPTRpush(argStkPtr); ptr = TAddress(evalStkPtr); k = stkevargs(ptr+1); obj = (k == aERROR ? brkerr() : ((funptr1)binfun)(k)); argStkPtr = SAVEPTRretr(); cleanup: EVALpop(); return(obj); } /*------------------------------------------------------------*/ /* ** Wendet die benutzerdefinierte Funktion *fun auf die bereits ** ausgewertete Argumentliste (arr,n) an. ** Es wird vorausgesetzt, dass die Argumente der Funktion *fun ** alle Wert-Parameter sind und die Anzahl gleich n ist. */ PUBLIC truc ufunapply(fun,arr,n) truc *fun; truc *arr; int n; { truc *fundefptr; truc obj; int k; fundefptr = TAddress(fun); SAVEPTRpush(argStkPtr); SAVEPTRpush(basePtr); basePtr = argStkPtr + 1; k = *VARCPTR(fundefptr); argvarspace(arr,n,VARSPTR(fundefptr),k); EVALpush(*(fundefptr + OFFS4body)); if(lvarsini(basePtr+n,k) == aERROR) { obj = brkerr(); } else { /* eval body, which is a compound statement */ obj = zero; k = *FUNARGCPTR(evalStkPtr); while(--k >= 0) { obj = eval(ARGNPTR(evalStkPtr,k)); if(obj == breaksym) { if(*brkmodePtr == retsym) { obj = *brkbindPtr; *brkbindPtr = zero; } break; } } } EVALpop(); basePtr = SAVEPTRretr(); argStkPtr = SAVEPTRretr(); return(obj); } /*------------------------------------------------------------*/ PRIVATE truc eval0(ptr,flg) truc *ptr; int flg; { struct symbol *sptr; if(flg == fSYMBOL) { sptr = SYMPTR(ptr); switch(*FLAGPTR(sptr)) { case sCONSTANT: case sSCONSTANT: case sVARIABLE: case sINTERNAL: case sSYSTEMVAR: return(sptr->bind.t); case sUNBOUND: error(evalsym,err_ubound,*ptr); return(brkerr()); default: return(*ptr); } } else if(flg == fLSYMBOL) { return(*LSYMBOLPTR(ptr)); } else if(flg == fRSYMBOL) { ptr = LSYMBOLPTR(ptr); if((flg = *FLAGPTR(ptr)) == fSYMBOL) return(eval(ptr)); else if(flg == fLRSYMBOL) { return(*LRSYMBOLPTR(ptr)); } else if(flg == fBUILTIN2 || flg == fSPECIAL2 || flg == fSPECIAL1) { /* array access or record access or pointer reference */ return(eval(ptr)); } else { error(evalsym,err_case,mkfixnum(flg)); return(brkerr()); } } else if(flg == fLRSYMBOL) { return(*LRSYMBOLPTR(ptr)); } else if(flg == fTMPCONST) { return(Lconsteval(ptr)); } else return(*ptr); } /*------------------------------------------------------------*/ /* ** ptr[0] contains number of arguments, ** ptr[1],...,ptr[n] are expressions for arguments ** argStkPtr wird veraendert! */ PRIVATE int stkevargs(ptr) truc *ptr; { truc *argptr; int i,n; n = *WORD2PTR(ptr); ptr++; argptr = argStkPtr + 1; argStkPtr += n; if(argStkPtr >= saveStkPtr) reset(err_astk); for(i=0; i= saveStkPtr) reset(err_astk); for(i=0; i= fBOOL) { argptr++; continue; } else if(flg < fFUNEXPR) { *argptr = eval0(argptr,flg); } if(*FLAGPTR(argptr) < fRECORD) { if((*argptr = eval(argptr)) == breaksym) return(aERROR); } if((flg = *FLAGPTR(argptr)) >= fRECORD && flg <= fVECTLIKE1) { *argptr = mkarrcopy(argptr); } argptr++; } return(n); } /*------------------------------------------------------------*/ PRIVATE int evalvargs(parms,argptr,n) truc parms; truc *argptr; int n; { int i, flg; unsigned depth; truc *ptr; depth = basePtr - ArgStack; WORKpush(parms); for(i=0; i= fBOOL) { argptr++; continue; } else if(flg < fFUNEXPR) { *argptr = eval0(argptr,flg); } if(*FLAGPTR(argptr) < fRECORD) { if((*argptr = eval(argptr)) == breaksym) { n = aERROR; break; } } if((flg = *FLAGPTR(argptr)) >= fRECORD && flg <= fVECTLIKE1) { *argptr = mkarrcopy(argptr); } argptr++; } cleanup: WORKpop(); return(n); } /*------------------------------------------------------------*/ PRIVATE truc vsymaux(argptr,depth) truc *argptr; unsigned depth; { unsigned u; truc *ptr; truc sym, obj; switch(*FLAGPTR(argptr)) { case fSYMBOL: return(*argptr); case fLSYMBOL: u = depth + *WORD2PTR(argptr); return(mklocsym(fLRSYMBOL,u)); case fRSYMBOL: return(*LSYMBOLPTR(argptr)); case fBUILTIN2: /* array access */ case fSPECIAL2: /* record access */ ptr = TAddress(argptr); sym = *ptr; ARGpush(ptr[1]); ARGpush(ptr[2]); if(sym == arr_sym || sym == subarrsym) { argStkPtr[-1] = vsymaux(argStkPtr-1,depth); argStkPtr[0] = eval(argStkPtr); } else if(sym == rec_sym) { argStkPtr[-1] = vsymaux(argStkPtr-1,depth); } else { ARGnpop(2); break; } obj = mkbnode(sym); ARGnpop(2); return(obj); } return(brkerr()); } /*------------------------------------------------------------*/ /* ** Initialisierung der lokalen Variablen */ PRIVATE int lvarsini(arr,n) truc *arr; int n; { truc obj; while(--n >= 0) { if((obj = eval(arr)) == breaksym) return(aERROR); *arr++ = obj; } return(1); } /*------------------------------------------------------------*/ PUBLIC truc arreval(arr,n) truc *arr; int n; { static truc res; res = voidsym; while(--n >= 0 && res != breaksym) res = eval(arr++); return(res); } /*********************************************************************/ aribas165b/src/file.c0000644000076600000240000005270414660570650013461 0ustar ottostaff/****************************************************************/ /* file file.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** file.c ** routines for file i/o ** ** date of last change ** 1995-01-25: ariExtens ** 1995-03-11: loadaux ** 1997-01-24: moved skiptolabel() from scanner.c to file.c ** 1997-02-03: findarifile ** 1997-04-13: changed skiptolabel, reorg (newintsym) ** 1998-12-27: issepdir() ** 2001-06-02: flush(transcript) ** 2007-08-29: Sopen0 ** 2008-02-21: corrected typo in isoutfile and isinpfile ** 2018-09-13 fixed minor errors and compiler warnings ** (thanks to D. Trebbien for testing) ** 2018-09-24: bugfix in Sopen0 */ #include "common.h" PUBLIC void inifile (void); PUBLIC int fnextens (char *str, char *name, char *extens); PUBLIC int findarifile (char *name, char *buf); PUBLIC int findfile (char *paths, char *fnam, char *buf); PUBLIC int issepdir (int ch); PUBLIC int isoutfile (truc *strom, int mode); PUBLIC int isinpfile (truc *strom, int mode); PUBLIC int loadaux (char *str, int verb, char *skipto); PUBLIC long filelen (truc *ptr); PUBLIC truc filesym; PUBLIC truc eofsym; PUBLIC truc tstdin, tstdout, tstderr; PUBLIC char *ariExtens = ".ari"; /*----------------------------------------------------------------------*/ PRIVATE truc stdinsym, stdoutsym, stderrsym; PRIVATE truc loadsym, openrsym, openwsym, openasym, closesym, flushsym; PRIVATE truc getcwdsym, setcwdsym; PRIVATE truc binarysym; PRIVATE truc rewindsym, setposym, getposym; PRIVATE truc rdbytesym, wrbytesym, rdblksym, wrblksym; PRIVATE int skiptolabel (truc *strom, char *lab); PRIVATE truc Fload (int argn); PRIVATE truc Sdumstream (void); PRIVATE truc openaux (char *name, int mode); PRIVATE int closestream (truc *strom); PRIVATE truc F1flush (int argn); PRIVATE truc Frewind (void); PRIVATE truc Fgetpos (void); PRIVATE truc Fsetpos (void); PRIVATE truc Fgetcwd (void); PRIVATE truc Fsetcwd (void); PRIVATE truc Sclose (void); PRIVATE int Sopen0 (truc symb, int mode); PRIVATE truc Sopenread (void); PRIVATE truc Sopenwrite (void); PRIVATE truc Sopenapp (void); PRIVATE truc Frdbyte (void); PRIVATE truc Fwrbyte (void); PRIVATE truc Srdblock (void); PRIVATE int Gblockaux (truc symb,FILE **pfil, size_t *anz, byte **pbuf); PRIVATE truc Swrblock (void); #ifdef genUNiX PRIVATE void expandtilde (char *buf); #endif /*----------------------------------------------------------------------*/ PUBLIC void inifile() { truc temp; temp = newintsym("", sSBINARY, (wtruc)Sdumstream); filesym = newsym("file", sTYPESPEC, mk0fun(temp)); eofsym = newselfsym("eof",sINTERNAL); binarysym = newreflsym("binary", sSYSSYMBOL); tstdin = mk0stream(stdin, INSTREAM | DEVICE); tstdout = mk0stream(stdout,OUTSTREAM | DEVICE); tstderr = mk0stream(stderr,OUTSTREAM | DEVICE); stdinsym = newsym("stdin", sSCONSTANT, tstdin); stdoutsym = newsym("stdout", sSCONSTANT, tstdout); stderrsym = newsym("stderr", sSCONSTANT, tstderr); loadsym = newsymsig("load", sFBINARY,(wtruc)Fload, s_12); openrsym = newsymsig("open_read", sSBINARY,(wtruc)Sopenread, s_23); openwsym = newsymsig("open_write", sSBINARY,(wtruc)Sopenwrite, s_23); openasym = newsymsig("open_append",sSBINARY,(wtruc)Sopenapp, s_23); closesym = newsymsig("close", sSBINARY,(wtruc)Sclose, s_bV); flushsym = newsymsig("flush", sFBINARY,(wtruc)F1flush, s_01); rewindsym = newsymsig("rewind", sFBINARY,(wtruc)Frewind, s_bV); setposym = newsymsig("set_filepos",sFBINARY,(wtruc)Fsetpos, s_2); getposym = newsymsig("get_filepos",sFBINARY,(wtruc)Fgetpos, s_1); getcwdsym = newsymsig("get_workdir",sFBINARY,(wtruc)Fgetcwd, s_0); setcwdsym = newsymsig("set_workdir",sFBINARY,(wtruc)Fsetcwd, s_1); rdbytesym = newsymsig("read_byte", sFBINARY,(wtruc)Frdbyte, s_1); wrbytesym = newsymsig("write_byte", sFBINARY,(wtruc)Fwrbyte, s_2); rdblksym = newsymsig("read_block", sSBINARY,(wtruc)Srdblock, s_3); wrblksym = newsymsig("write_block",sSBINARY,(wtruc)Swrblock, s_3); } /*----------------------------------------------------------------------*/ /* ** load(FileName) */ PRIVATE truc Fload(argn) int argn; /* argn = 1 or 2 */ { truc *argptr; char *argv[ARGCMAX]; char name[MAXPFADLEN+4]; word2 *offsets; char *str, *str0; int ret, strerr, verbose; int i, count; argptr = argStkPtr-argn+1; if(*FLAGPTR(argptr) == fSTRING) { str = STRINGPTR(argptr); strerr = (str[0] ? 0 : 1); } else strerr = 1; if(strerr) { error(loadsym,err_str,*argptr); return(brkerr()); } if(argn == 2 && *argStkPtr == zero) { verbose = 0; } else verbose = 1; str0 = (char *)AriBuf; offsets = AriScratch; strncopy(str0,str,IOBUFSIZE); count = stringsplit(str0,NULL,offsets); if(count > ARGCMAX) count = ARGCMAX; for(i=0; i=0; --i) { if(ch == SEP_DIR[i]) return 1; } return 0; } /*----------------------------------------------------------------------*/ /* ** Sucht ein File namens name mit ARIBAS source code ** Zunaechst wird im aktuellen Directory gesucht, dann in ** den durch apathsym gegebenen Pfaden. ** Falls name nicht die Endung .ari hat, wird auch nach einem ** File mit dem durch die Endung .ari erweiterten Namen gesucht. ** Bei Erfolg ist der Rueckgabewert = 1, der Name, unter dem ** die Datei gefunden wurde, wird nach buf kopiert. ** Bei Misserfolg wird 0 zurueckgegeben. */ PUBLIC int findarifile(name,buf) char *name, *buf; { static char path0[2] = {SEPPATH,0}; char *fnam[2]; char *paths; char nam1[MAXPFADLEN+4]; int ext,k; ext = fnextens(name,nam1,ariExtens); fnam[0] = nam1; fnam[1] = name; paths = SYMname(apathsym); for(k=0; k<=ext; k++) { if(findfile(path0,fnam[k],buf)) return(1); if(findfile(paths,fnam[k],buf)) return(1); } strcopy(buf,name); return(0); } /*-----------------------------------------------------------*/ /* ** sucht eine Datei namens fnam in den Directories, ** die durch den String paths gegeben werden. ** Falls gefunden, wird der vollstaendige Pfad in buf abgelegt ** und 1 zurueckgegeben; bei Misserfolg ist der Rueckgabewert 0. */ PUBLIC int findfile(paths,fnam,buf) char *paths, *fnam, *buf; { int ch; char *ptr, *ptr2; FILE *fil; ptr = paths; ch = *ptr; while(ch) { ptr2 = buf; if(*ptr == SEPPATH) ptr++; while((ch = *ptr++) && (ch != SEPPATH)) *ptr2++ = ch; if(!issepdir(ch) && (ptr2 != buf)) *ptr2++ = SEP_DIR[0]; strcopy(ptr2,fnam); #ifdef genUNiX if(strncmp(buf,"~/",2) == 0) { expandtilde(buf); } #endif fil = fopen(buf,"r"); if(fil != NULL) { fclose(fil); return(1); } } return(0); } /*-------------------------------------------------------------*/ #ifdef genUNiX PRIVATE void expandtilde(buf) char *buf; { char hbuf[MAXPFADLEN+2]; char *home; int n; home = getenv("HOME"); if(home != NULL) { n = strncopy(hbuf,home,MAXPFADLEN); if(issepdir(hbuf[n-1])) n--; strncopy(hbuf+n,buf+1,MAXPFADLEN-n); strncopy(buf,hbuf,MAXPFADLEN); } return; } #endif /*-------------------------------------------------------------*/ PUBLIC int fnextens(str,name,extens) char *str, *name, *extens; { int k,n,n1,m,ch; n = strncopy(name,str,MAXPFADLEN); m = strlen(extens); if((n >= m) && (strcmp(extens,name+(n-m)) == 0)) return(0); n1 = (n > m ? n-m: 0); for(k=n-1; k>=n1; k--) { ch = name[k]; if(ch == '.') return(0); else if(!isdigalfa(ch)) break; } strcopy(name+n,extens); return(1); } /*-------------------------------------------------------------*/ PUBLIC int isoutfile(strom,mode) truc *strom; int mode; /* aTEXT or BINARY */ { struct stream *strmptr; int fmode; strmptr = STREAMPTR(strom); fmode = strmptr->mode; return((fmode & OUTSTREAM) && ((fmode & BINARY) == mode)); } /*-------------------------------------------------------------*/ PUBLIC int isinpfile(strom,mode) truc *strom; int mode; /* aTEXT or BINARY */ { struct stream *strmptr; int fmode; strmptr = STREAMPTR(strom); fmode = strmptr->mode; return((fmode & INSTREAM) && ((fmode & BINARY) == mode)); } /*-------------------------------------------------------------*/ PRIVATE truc Sdumstream() { return(mkstream(NULL,NOSTREAM)); } /*-------------------------------------------------------------*/ PRIVATE truc openaux(name,mode) char *name; int mode; { FILE *file; char access[4]; // static char dum[3] = {' ','\b',0}; if(mode & INSTREAM) strcopy(access,"r"); else if(mode & OUTSTREAM) { if(mode & APPEND) strcopy(access,"a"); else strcopy(access,"w"); } else return(brkerr()); if(mode & BINARY) strcopy(access+1,"b"); file = fopen(name,access); if(file == NULL) { return(breaksym); } return(mkstream(file,mode)); } /*----------------------------------------------------------*/ /* ** returns 0 if successfully closed, otherwise EOF */ PRIVATE int closestream(strom) truc *strom; { struct stream *fluss; int ret; fluss = STREAMPTR(strom); if(fluss->mode == NOSTREAM) return(EOF); else fluss->mode = NOSTREAM; /* arg is no longer a stream */ ret = fclose(fluss->file); fluss->file = NULL; return(ret); } /*------------------------------------------------------------*/ /* ** Liest aus strom soviel Zeilen, bis ** label am Anfang einer Zeile (evtl. nach blanks) entdeckt wird */ PRIVATE int skiptolabel(strom,lab) truc *strom; char *lab; { struct stream *strmptr; FILE *fil; char *str; size_t len = strlen(lab); int count = 0; strmptr = STREAMPTR(strom); fil = strmptr->file; while(fgets(StrBuf,IOBUFSIZE,fil)) { count++; str = trimblanks(StrBuf,0); if(strncmp(lab,str,len) == 0) break; } strmptr->lineno += count; return(count); } /*----------------------------------------------------------*/ /* ** Rueckgabewert: 1 bei Erfolg, ** EXITREQ (=-1) bei exit-Wunsch ** 0 bei err_open ** aERROR bei Fehler ** ** if skipto != NULL, all lines inclusive the line with skipto are skipped */ #define SKIPLABEL "-init" PUBLIC int loadaux(fnam,verb,skipto) char *fnam; int verb; char *skipto; { truc *pstrom; truc strom; truc obj, res; int ret = 0; strom = openaux(fnam,INSTREAM); if(strom == breaksym) { error(loadsym,err_open,scratch(fnam)); return(0); } WORKpush(strom); pstrom = workStkPtr; if(skipto) { skiptolabel(pstrom,skipto); } while((obj = tread(pstrom,FILEINPUT)) != eofsym) { res = eval(&obj); if(res == breaksym) { if(*brkmodePtr == exitsym) ret = EXITREQ; else ret = aERROR; break; } if(verb) { tprint(tstdout,res); fnewline(tstdout); } } closestream(pstrom); workStkPtr = pstrom - 1; return(ret); } /*----------------------------------------------------------*/ PRIVATE truc F1flush(argn) int argn; { struct stream *strm; FILE *fptr; if(argn == 0) { fptr = stdout; } else if(*FLAGPTR(argStkPtr) == fSTREAM) { strm = STREAMPTR(argStkPtr); if(strm->mode & OUTSTREAM) fptr = strm->file; else goto ausgang; } else { if(*argStkPtr == transcsym) flushlog(); goto ausgang; } fflush(fptr); ausgang: return(voidsym); } /*----------------------------------------------------------*/ PRIVATE truc Frewind() { struct stream *strm; int mode, flg; flg = *FLAGPTR(argStkPtr); if(flg == fSTREAM) strm = STREAMPTR(argStkPtr); if(flg != fSTREAM || !((mode=strm->mode) & INSTREAM) || mode & DEVICE) { /* Fehlermeldung fehlt! */ return(false); } rewind(strm->file); return(true); } /*----------------------------------------------------------*/ PUBLIC long filelen(ptr) truc *ptr; { FILE *fil; struct stream *strm; long pos, len; int mode; strm = STREAMPTR(ptr); mode = strm->mode; if(mode == NOSTREAM || (mode & DEVICE)) return(-1); fil = strm->file; pos = ftell(fil); if(mode & OUTSTREAM) return(pos); else { fseek(fil,0L,2); /* 2 = from end */ len = ftell(fil); fseek(fil,pos,0); /* 0 = from start */ return(len); } } /*----------------------------------------------------------*/ PRIVATE truc Fgetpos() { struct stream *strm; long pos; int flg; flg = *FLAGPTR(argStkPtr); if(flg == fSTREAM) strm = STREAMPTR(argStkPtr); if(flg != fSTREAM || !(strm->mode & BINARY)) { /* Fehlermeldung fehlt */ return(brkerr()); } pos = ftell(strm->file); return(mkinum(pos)); } /*----------------------------------------------------------*/ PRIVATE truc Fsetpos() { struct stream *strm; FILE *fil; word2 *x; word4 u; long pos0, pos, len; int flg, n, sign; flg = *FLAGPTR(argStkPtr-1); if(flg == fSTREAM) strm = STREAMPTR(argStkPtr-1); if(flg != fSTREAM || strm->mode != (INSTREAM | BINARY)) { error(setposym,err_binp,voidsym); return(brkerr()); } if(chkints(setposym,argStkPtr,1) == aERROR) return(brkerr()); n = bigref(argStkPtr,&x,&sign); if (sign || (n > 2) || (n == 2 && x[1] > 0x7FFF)) { error(setposym,err_p4int,*argStkPtr); pos = -1; } else { u = big2long(x,n); pos = (long)u; } fil = strm->file; pos0 = ftell(fil); fseek(fil,0L,2); /* 2 = from end */ len = ftell(fil); if(pos < 0 || pos > len) pos = pos0; fseek(fil,pos,0); /* 0 = from start */ return(mkinum(pos)); } /*----------------------------------------------------------*/ PRIVATE truc Sclose() { truc *ptr, *fptr; int ret; ptr = ARG0PTR(evalStkPtr); if(Lvaladdr(ptr,&fptr) != vBOUND || *FLAGPTR(fptr) != fSTREAM) { error(closesym,err_filv,*ptr); return(false); } ret = closestream(fptr); return(ret == 0 ? true : false); } /*----------------------------------------------------------*/ PRIVATE int Sopen0(symb,mode) truc symb; int mode; { truc *ptr, *fptr; truc fobj; char *str; int argn, ret; argn = *ARGCOUNTPTR(evalStkPtr); /* second argument: file name */ WORKpush(*ARGNPTR(evalStkPtr,2)); *workStkPtr = eval(workStkPtr); if(*FLAGPTR(workStkPtr) != fSTRING) { error(symb,err_str,*workStkPtr); return(aERROR); } /* third argument: mode */ if(argn == 3) { ptr = ARGNPTR(evalStkPtr,3); if(*ptr == binarysym) mode |= BINARY; else { error(symb,err_pars,*ptr); return(aERROR); } } /* first argument: file variable */ ptr = ARG1PTR(evalStkPtr); ret = Lvaladdr(ptr,&fptr); if(ret != vBOUND && ret != vUNBOUND) { /* fehlt type check */ error(symb,err_sym,*ptr); return(aERROR); } str = STRINGPTR(workStkPtr); WORKpop(); if(strlen(str) > MAXPFADLEN) { error(symb,err_n2long,voidsym); return(aERROR); } fobj = openaux(str,mode); if(fobj == breaksym) return(aERROR); else { *fptr = fobj; return(0); } } /* ---------------------------------------------------------*/ PRIVATE truc Sopenread() { int ret = Sopen0(openrsym,INSTREAM); return(ret == aERROR ? false : true); } /* ---------------------------------------------------------*/ PRIVATE truc Sopenwrite() { int ret = Sopen0(openwsym,OUTSTREAM); return(ret == aERROR ? false : true); } /*----------------------------------------------------------*/ PRIVATE truc Sopenapp() { int ret = Sopen0(openasym,(OUTSTREAM | APPEND)); return(ret == aERROR ? false : true); } /*----------------------------------------------------------*/ PRIVATE truc Frdbyte() { struct stream *strm; int ch; int flg; flg = *FLAGPTR(argStkPtr); if(flg != fSTREAM || !isinpfile(argStkPtr,BINARY)) { error(rdbytesym,err_binp,voidsym); return(brkerr()); } strm = STREAMPTR(argStkPtr); ch = fgetc(strm->file); return(mksfixnum(ch)); } /*----------------------------------------------------------*/ PRIVATE truc Fwrbyte() { struct stream *strm; int ch; int flg; flg = *FLAGPTR(argStkPtr-1); if(flg != fSTREAM || !isoutfile(argStkPtr-1,BINARY)) { error(wrbytesym,err_bout,voidsym); return(brkerr()); } flg = *FLAGPTR(argStkPtr); if(flg == fFIXNUM) { ch = *WORD2PTR(argStkPtr); if(*SIGNPTR(argStkPtr)) ch = -ch; } else if(flg == fCHARACTER) { ch = *WORD2PTR(argStkPtr); } else return(mksfixnum(-1)); strm = STREAMPTR(argStkPtr-1); ch = fputc(ch,strm->file); #ifdef ATARIST ch &= 0x00FF; /* Fehler in ATARI-Turbo-C-Compiler, v. 1.0 */ #endif return(mksfixnum(ch)); } /*----------------------------------------------------------*/ PRIVATE truc Srdblock() { FILE *fil; byte *bpt; size_t anz; unsigned n; int ret; ret = Gblockaux(rdblksym,&fil,&anz,&bpt); if(ret == aERROR) return(brkerr()); n = fread(bpt,1,anz,fil); return(mkfixnum(n)); } /*----------------------------------------------------------*/ PRIVATE int Gblockaux(symb,pfil,panz,pbuf) truc symb; FILE **pfil; size_t *panz; byte **pbuf; { struct stream *strm; truc *optr, *argptr, *bufptr; truc obj; size_t anz; unsigned len; int ret, flg; optr = &obj; /* 1. Argument: file */ obj = eval(ARG1PTR(evalStkPtr)); flg = *FLAGPTR(optr); if(symb == rdblksym) { if(flg != fSTREAM || !isinpfile(optr,BINARY)) { error(symb,err_binp,voidsym); return(aERROR); } } else if(symb == wrblksym) { if(flg != fSTREAM || !isoutfile(optr,BINARY)) { error(symb,err_bout,voidsym); return(aERROR); } } strm = STREAMPTR(optr); *pfil = strm->file; /* 3. Argument: Anzahl */ obj = eval(ARGNPTR(evalStkPtr,3)); if(*FLAGPTR(optr) != fFIXNUM) { error(symb,err_pfix,obj); return(aERROR); } anz = *WORD2PTR(optr); /* 2. Argument: Puffer als byte_string */ argptr = ARGNPTR(evalStkPtr,2); ret = bytestraddr(argptr,&bufptr,pbuf,&len); if(ret == aERROR) { error(symb,err_vbystr,*argptr); } else if(len < anz) { error(symb,err_buf,voidsym); ret = aERROR; } else *panz = anz; return(ret); } /*----------------------------------------------------------*/ PRIVATE truc Swrblock() { FILE *fil; byte *bpt; size_t anz; unsigned n; int ret; ret = Gblockaux(wrblksym,&fil,&anz,&bpt); if(ret == aERROR) return(brkerr()); n = fwrite(bpt,1,anz,fil); return(mkfixnum(n)); } /*----------------------------------------------------------*/ PRIVATE truc Fgetcwd() { char *pfad; pfad = getworkdir(); return mkstr(pfad); } /*----------------------------------------------------------*/ PRIVATE truc Fsetcwd() { int res, len; char pfad[MAXPFADLEN]; char *pf1; if(*FLAGPTR(argStkPtr) != fSTRING) { error(setcwdsym,err_str,*argStkPtr); return brkerr(); } len = *STRLENPTR(argStkPtr); if(len < MAXPFADLEN) { strncopy(pfad,STRINGPTR(argStkPtr),MAXPFADLEN); #ifdef genUNiX if(strncmp(pfad,"~/",2) == 0) { expandtilde(pfad); } #endif res = setworkdir(pfad); } else res = 0; if(res == 0) pf1 = ""; else pf1 = getworkdir(); return mkstr(pf1); } /**************************************************************/ aribas165b/src/logscr.inc0000644000076600000240000004551414660570647014371 0ustar ottostaff/****************************************************************/ /* file logscr.inc ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** logscr.inc ** logical screen ** ** date of last change ** 1995-03-22: Bremse in L_strappend ** 1998-01-03: cosmetic changes ** 1998-05-31: #define-s for Win32GUI ** 2002-02-16: L_text2blatt, L_insidecomment */ #if defined(UNiXorGCC) || defined(Win32GUI) #define LINELEN 162 #define BUFLINES 200 #else #define LINELEN 82 #define BUFLINES 50 #endif typedef char zeile[LINELEN]; #define LOCAL static LOCAL zeile *Blatt = NULL; /* ** Zeilen-Nummern beginnen bei 0 ** Die einzelnen Zeilen haben in Position 0 die Zeilenlaenge ** Die Strings werden durch ein Null-Byte abgeschlossen ** Es gilt also stets fuer ptr = Blatt[n], dass ptr[ptr[0]+1] = 0 */ LOCAL int L_iniscr (zeile *Buf, char *prompt); LOCAL int L_insert (int n); LOCAL void L_strappend (int n, int i, char *str); LOCAL int L_len (int n); LOCAL int L_pagelen (void); LOCAL int L_efflen (void); LOCAL int L_efffirst (void); LOCAL int L_indent (int n); LOCAL int L_trimlen (int n); LOCAL int L_compress (void); LOCAL int L_expand (byte *buf); LOCAL char *L_linerest (int n, int k); LOCAL char *L_line (int n); PRIVATE void L_nulline (int n); PRIVATE void L_linecpy (char *z1, char *z2); PRIVATE int L_makebstream(int lineno); PRIVATE int L_bnextch(void); PRIVATE int L_bpeekch(void); PRIVATE int L_bskiptoeol(void); PRIVATE int L_bskiptoeostr(void); PRIVATE int L_bstream(int mode); LOCAL int L_insidecomment(int lineno); #ifdef genWinGUI LOCAL int L_text2blatt(char *buf); #endif #ifdef PAGEINPUT LOCAL void L_clreol (int n, int i); LOCAL void L_delete (int n); LOCAL int L_spaceins (int n, int i, int anz, int bound); LOCAL int L_charins (int n, int i, int ch, int bound); LOCAL int L_chardel (int n, int i); LOCAL int L_charndel (int n, int i, int anz); LOCAL int L_nextgroup (int n, int k); LOCAL int L_prevgroup (int n, int k); LOCAL int L_nextword (int n, int k); LOCAL int L_merge (int n, int bound); LOCAL int L_retbreak (int n, int k); #endif LOCAL int Col0; /* in der 0-ten Zeile nach Prompt */ PRIVATE int Actlen = 0; /*--------------------------------------------------------------------*/ LOCAL int L_iniscr(Buf,prompt) zeile *Buf; char *prompt; { int n; int ch; char *ptr; Blatt = Buf; Actlen = 1; ptr = Blatt[0]; n = 0; while((ch = *prompt++)) { n++; ptr[n] = ch; } ptr[n+1] = 0; ptr[0] = n; Col0 = n+1; for(n=1; n= BUFLINES) return(0); for(i=Actlen; i>n; i--) L_linecpy(Blatt[i],Blatt[i-1]); L_nulline(n); Actlen++; return(1); } /*-------------------------------------------------------------------*/ PRIVATE void L_linecpy(z1,z2) char *z1, *z2; { *z1++ = *z2++; strcpy(z1,z2); } /*-------------------------------------------------------------------*/ /* ** Schreibt in Zeile n ab Position i den String str; ** Es wird vorausgesetzt, dass n < Actlen und 1 <= i < LINELEN-1 ** Falls str zu lang ist, wird abgeschnitten */ LOCAL void L_strappend(n,i,str) int n,i; char *str; { char *ptr, *ptr0; ptr0 = Blatt[n]; ptr = ptr0 + i; while((*ptr++ = *str++) && (i < LINELEN-1)) i++; ptr0[i] = 0; ptr0[0] = i - 1; } /*-------------------------------------------------------------------*/ /* ** Laenge der n-ten Zeile */ LOCAL int L_len(n) int n; { return(Blatt[n][0]); } /*-------------------------------------------------------------------*/ LOCAL int L_pagelen() { return(Actlen); } /*-------------------------------------------------------------------*/ /* ** effektive Laenge; leere Zeilen am Ende zaehlen nicht */ LOCAL int L_efflen() { int n; n = Actlen; while(n > 1 && Blatt[n-1][0] == 0) n--; return(n); } /*-------------------------------------------------------------------*/ /* ** effektive erste Zeile */ LOCAL int L_efffirst() { int i; if(Blatt[0][0] > Col0) return(0); for(i=1; i= Actlen) return(0); ptr = Blatt[n]; k = (n > 0 ? 1 : Col0); while(ptr[k] == ' ') k++; return(k-1); } /*-------------------------------------------------------------------*/ /* ** Laenge der Zeile n ohne Leerzeichen am Ende */ LOCAL int L_trimlen(n) int n; { int k, k0; char *ptr; if(n >= Actlen) return(0); ptr = Blatt[n]; k = ptr[0]; k0 = (n > 0 ? 1 : Col0); while(k >= k0 && ptr[k] == ' ') k--; return(k); } /*-------------------------------------------------------------------*/ /* ** Komprimiert den Text in Blatt durch Ersetzen von Leerzeichen ** am Anfang der Zeile durch verallgemeinerte TAB's. ** Der entstehende String wird in den Puffer Blatt geschrieben. ** Rueckgabewert: Laenge des entstehenden Strings */ LOCAL int L_compress() { char *ptr1, *str; int i, k, len, n; n = L_efflen(); ptr1 = Blatt[0]; for(i=0; i= 0) *ptr1++ = *str++; } *ptr1 = 0; return(ptr1 - Blatt[0]); } /*-------------------------------------------------------------------*/ /* ** Umkehrung von L_compress ** Der komprimierte String steht in buf; das Ergebnis in Blatt ** Rueckgabewert: Laenge in Zeilen; */ LOCAL int L_expand(buf) byte *buf; { int i, k, n; int ch; char *ptr; for(n=0, ch=*buf++; ch && n 0 ? 1 : Col0); while(i <= k) ptr[i++] = ' '; while((ch = *buf++) > TABESC) ptr[i++] = ch; ptr[i] = 0; ptr[0] = i-1; } Actlen = n; return(n); } /*-------------------------------------------------------------------*/ LOCAL char *L_linerest(n,k) int n, k; { char *ptr; ptr = Blatt[n]; if(k > ptr[0]) k = ptr[0] + 1; return(ptr + k); } /*-------------------------------------------------------------------*/ LOCAL char *L_line(n) int n; { char *ptr; ptr = Blatt[n]; return(ptr + 1); } /*-------------------------------------------------------------------*/ #ifdef genWinGUI /*-------------------------------------------------------------------*/ /* ** copies text from buffer buf to Blatt ** return value: actual length of Blatt ** or -1 if text is too long */ LOCAL int L_text2blatt(buf) char *buf; { int i, n; int ch; char *ptr; for(n=0, ch=*buf++; ch && n 0 ? 1 : Col0); while(ch && ch != '\n' && i= 0) { /* makebstream */ if(Blatt == NULL) return(-1); lastline = mode; if(lastline >= BUFLINES) lastline = BUFLINES-1; curline = 0; curlen = Blatt[curline][0]; col = 1; return(lastline); } nochmal: switch(mode) { case -1: /* bnextch */ if(curline > lastline) return(EOF); else if(col > curlen) { curline++; col = 1; if(curline <= lastline) curlen = Blatt[curline][0]; else curlen = 0; return(EOL); } else { ch = Blatt[curline][col]; col++; return(ch); } break; case -2: /* bpeekch */ if(curline > lastline) return(EOF); else if(col > curlen) return(EOL); else return Blatt[curline][col]; break; case -3: /* skiptoeol */ curline++; col = 1; if(curline <= lastline) curlen = Blatt[curline][0]; else curlen = 0; return(EOL); break; case -4: /* skip to end of string */ if(col > curlen || curline > lastline) { mode = -1; goto nochmal; } while(col <= curlen) { ch = Blatt[curline][col]; col++; if(ch == '"') break; } break; default: break; } return(-1); } /*-------------------------------------------------------------------*/ /*-------------------------------------------------------------------*/ #ifdef PAGEINPUT /*-------------------------------------------------------------------*/ LOCAL void L_clreol(n,i) int n, i; { char *ptr; ptr = Blatt[n]; ptr[i] = 0; ptr[0] = i - 1; } /*-------------------------------------------------------------------*/ /* ** Loescht in Blatt die n-te Zeile; ** alle folgenden Zeilen werden um eins nach oben verschoben */ LOCAL void L_delete(n) int n; { int i; if(n >= Actlen) return; for(i=n+1; i Zeilenlaenge), keine Aktion, Rueckgabewert 0 ** Andernfalls Rueckgabewert anz */ LOCAL int L_spaceins(n,i,anz,bound) int n,i,anz,bound; { char *ptr; int k, len; ptr = Blatt[n]; len = ptr[0]; if(n >= Actlen || i > len || len+anz > bound) return(0); ptr[0] = len + anz; for(k=len+1; k>=i; k--) ptr[k+anz] = ptr[k]; for(k=0; k Zeilenlaenge+1, werden vor ch Leerzeichen eingefuellt */ LOCAL int L_charins(n,i,ch,bound) int n,i,ch,bound; { char *ptr; int k, len; ptr = Blatt[n]; len = ptr[0]; if(len >= bound) return(0); if(i <= len) { len++; for(k=len; k>=i; k--) ptr[k+1] = ptr[k]; ptr[i] = ch; } else { for(k=len+1; k= anz ist ** Falls i > Zeilenlaenge, werden entsprechend weniger ** Buchstaben gestrichen. ** Rueckgabewert: Anzahl der tatsaechlich entfernten Zeichen */ LOCAL int L_charndel(n,i,anz) { char *ptr; int k, len; ptr = Blatt[n]; len = ptr[0]; if(i > len) return(0); else if(i >= len - anz + 1) { ptr[i] = 0; ptr[0] = i - 1; return(len - i + 1); } else { ptr[0] = len - anz; for(k=i; k<=len+1-anz; k++) ptr[k] = ptr[k+anz]; return(anz); } } /*-------------------------------------------------------------------*/ /* ** Fuer Cursor-Bewegung mit CTRL-Pfeilrechts: ** Gibt Position der naechsten Gruppe von Zeichen ohne Spaces */ LOCAL int L_nextgroup(n,k) int n,k; { char *ptr; int ch; if(n >= Actlen) return(k); ptr = Blatt[n]; if(k > ptr[0]) return(k); while((ch = ptr[k]) && ch != ' ') k++; while((ch = ptr[k]) && ch == ' ') k++; return(k); } /*-------------------------------------------------------------------*/ /* ** Fuer Cursor-Bewegung mit CTRL-Pfeillinks: ** Gibt Anfang der vorherigen Gruppe von Zeichen ohne Spaces */ LOCAL int L_prevgroup(n,k) int n,k; { char *ptr; int len; int k0; if(n >= Actlen) return(k); k0 = (n > 0 ? Col0 : 1); ptr = Blatt[n]; len = ptr[0]; if(len == 0) return(1); else if(k > len) k = len; else if(k > k0) k--; while(k > k0 && ptr[k] == ' ') k--; while(k > k0 && ptr[k-1] != ' ') k--; return(k); } /*-------------------------------------------------------------------*/ /* ** gibt Postion des Anfangs des naechsten Wortes fuer das ** Kommando Wort loeschen. ** Es wird bis zu dieser Position ausschliesslich geloescht ** */ LOCAL int L_nextword(n,k) int n,k; { char *ptr; int ch; if(n >= Actlen) return(k); ptr = Blatt[n]; if(k > ptr[0]) return(k); ch = ptr[k]; if(isdigalfa(ch)) { k++; while((ch = ptr[k]) && isdigalfa(ch)) k++; } else if(ch != ' ') { k++; while((ch = ptr[k]) && ch != ' ' && !isdigalfa(ch)) k++; } else { k++; while(ptr[k] == ' ') k++; } return(k); } /*-------------------------------------------------------------------*/ /* ** Die Zeile n wird mit der Zeile n+1 zusammengefuegt und der ** Rest des Blattes nach oben gezogen. ** Voraussetzung ist, dass die Summe der Zeilenlaengen ** <= bound ist. In diesem Fall ist der Rueckgabewert die ** Position des Anfangs der angehaengten Zeile in Zeile n. ** Falls die Summe der Zeilenlaengen > bound ist, wird ** das Blatt unveraendert gelassen und 0 zurueckgegeben. ** Ausserdem wird vorausgesetzt, dass die Zeile n+1 existiert; ** andernfalls keine Aktion und Rueckgabewert 0. */ LOCAL int L_merge(n, bound) int n, bound; { int k; char *str; if(n >= L_pagelen() - 1) return(0); k = L_len(n); if(k + L_len(n+1) > bound) return(0); else { str = L_linerest(n+1,1); L_strappend(n,k+1,str); L_delete(n+1); return(k+1); } } /*-------------------------------------------------------------------*/ /* ** Fuehrt einen Umbruch (wie bei Betaetigung der Return-Taste) ** von Zeile n ab Position k in eine neuzuschaffende naechste ** Zeile durch. ** Falls Blatt zu lang wuerde, wird keine Aktion durchgefuehrt ** und 0 zurueckgegeben; sonst Rueckgabewert 1. */ LOCAL int L_retbreak(n,k) int n,k; { char *str; int len; len = L_pagelen(); if(len >= BUFLINES || n >= len) return(0); L_insert(n+1); if(k <= L_len(n)) { str = L_linerest(n,k); L_strappend(n+1,1,str); L_clreol(n,k); } return(1); } /*-------------------------------------------------------------------*/ #endif /* PAGEINPUT */ #undef LOCAL /*********************************************************************/ aribas165b/src/mainloop.c0000644000076600000240000005776214660570647014377 0ustar ottostaff/*****************************************************************/ /* file mainloop.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de WWW http://www.mathematik.uni-muenchen.de/~forster */ /*****************************************************************/ /* ** mainloop.c ** mainloop, error handling and help system ** ** date of last change ** 96-10-18: architec[] ** 97-01-26: aripath, argload ** 97-04-11: changed findhelpfile(), helptopic(), cfgfile() ** 97-04-18: changed Fsystem() ** 97-05-27: option -b (batch mode) ** 97-07-12: reorg commandline options ** 97-08-02: getenv ** 97-08-28: improved findhelpfile() */ /*------------------------------------------------------------*/ #include "common.h" #include #ifdef DOSorUNiX #include #endif #ifdef MsDOS #define genDOS #endif #ifdef DjGPP #define genDOS #endif /*------------------------------------------------------------*/ #ifdef ARCHITEC static char architec[] = ARCHITEC; #else static char architec[] = "???"; #endif static char Version[] = VERSION_STRING; static int version_no = VERSION_NO; static char versionyear[] = VERSION_YEAR; static char Email[] = "forster@mathematik.uni-muenchen.de"; #ifdef DTRACE PUBLIC FILE *DTraceF; PUBLIC int DTraceWrite(char *mess); PUBLIC char DTraceZeile[80]; #endif /*--------------------------------------------------------------*/ /********* prototypes of exported functions ************/ PUBLIC int error (truc source, char *message, truc obj); PUBLIC void setinterrupt (int flg); PUBLIC void reset (char *message); PUBLIC void faterr (char *mess); #ifdef DOSorUNiX PUBLIC void ctrlcreset (int sig); #endif PUBLIC int Unterbrech = 0; PUBLIC truc *res1Ptr, *res2Ptr, *res3Ptr; PUBLIC truc helpsym; PUBLIC truc apathsym; /*-----------------------------------------------------*/ PRIVATE char *HelpFile = "aribas.hlp"; PRIVATE char *InitLabel = "-init"; #ifdef genUNiX #define MAXCMDLEN 256 PRIVATE char *CfgFile = ".arirc"; #else #define MAXCMDLEN 128 PRIVATE char *CfgFile = "aribas.cfg"; #endif struct options { int mem; int cols; int verbose; int batchflg; char *helppath; char *aripath; char *loadinit; char *loadname; char *home; int argc; char **argv; char helpbuf[MAXPFADLEN+2]; char pathbuf[MAXPFADLEN+4]; char inibuf[MAXPFADLEN+2]; char homebuf[MAXPFADLEN+2]; }; PRIVATE FILE *findcfg (struct options *popt); PRIVATE void iniopt (struct options *popt, char *argv0); PRIVATE int cfgfile (struct options *popt); PRIVATE int main0 (int argc, char *argv[]); PRIVATE int commandline (int argc, char *argv[], struct options *popt); PRIVATE int findhelpfile (struct options *popt); PRIVATE void initialize (struct options *popt); PRIVATE void inimain (struct options *popt); PRIVATE void title (void); PRIVATE int argload (char *fil, int verb); PRIVATE int mainloop (void); PRIVATE void toprespush (truc obj); PRIVATE truc Fhalt (int argn); PRIVATE truc Fversion (int argn); PRIVATE void resetcleanup (char *message); PRIVATE truc Shelp (void); PRIVATE int helpintro (void); PRIVATE int helptopic (char *topic); PRIVATE void displaypage (char *txtarr[]); #ifdef DOSorUNiX PRIVATE truc systemsym; PRIVATE truc Fsystem (void); PRIVATE truc getenvsym; PRIVATE truc Fgetenv (void); #endif PRIVATE truc hlpfilsym; PRIVATE truc res1sym, res2sym, res3sym; PRIVATE truc verssym; PRIVATE truc haltsym; PRIVATE truc haltret; PRIVATE jmp_buf globenv; PRIVATE int setjumpflg = 0; PRIVATE int mainret = 0; #ifdef TT /* nur fuer Test-Zwecke */ PRIVATE truc ttsym; PRIVATE truc Ftt (void); #endif /* TT */ /*---------------------------------------------------------------*/ int main(argc,argv) int argc; char *argv[]; { int ret; ret = main0(argc,argv); #ifdef DTRACE DTraceF = fopen("DTraceF.txt","w"); if(DTraceF == NULL) { ret = EXITREQ; } #endif if(ret != EXITREQ) ret = mainloop(); else ret = 0; #ifdef DTRACE if(DTraceF) fclose(DTraceF); #endif closelog(); dealloc(); epilogue(); exit(ret); return ret; } /*------------------------------------------------------------------*/ PRIVATE int main0(argc,argv) int argc; char *argv[]; { struct options opt; int ret; int verb; iniopt(&opt,argv[0]); cfgfile(&opt); commandline(argc,argv,&opt); findhelpfile(&opt); prologue(); initialize(&opt); verb = opt.verbose; if(verb) title(); if(opt.loadinit) { if(verb) { fnewline(tstdout); fprintline(tstdout,"(** loading init code **)"); } ret = loadaux(opt.loadinit,verb,InitLabel); } iniargv(opt.argc,opt.argv); if(opt.loadname) { ret = argload(opt.loadname,verb); if(opt.batchflg) ret = EXITREQ; } else ret = 0; return(ret); } /*------------------------------------------------------------------*/ #ifdef DTRACE PUBLIC DTraceWrite(mess) char *mess; { fprintf(DTraceF,mess); } #endif /*------------------------------------------------------------------*/ PRIVATE void iniopt(popt,argv0) struct options *popt; char *argv0; { char *home; char *str; #ifdef genDOS int n; #endif home = popt->homebuf; home[0] = 0; #ifdef genUNiX str = getenv("HOME"); if(str != NULL) strncopy(home,str,MAXPFADLEN); #endif #ifdef genDOS if(argv0 != NULL) { n = strncopy(home,argv0,MAXPFADLEN); while((--n >= 0) && !issepdir(home[n])) ; home[n] = 0; } #endif popt->home = home; popt->mem = popt->cols = 0; popt->verbose = 1; popt->batchflg = 0; popt->loadname = NULL; popt->helppath = NULL; popt->aripath = NULL; popt->loadinit = NULL; } /*------------------------------------------------------------------*/ PRIVATE FILE *findcfg(popt) struct options *popt; { FILE *fil; char *buf, *str; int n; buf = popt->inibuf; fil = fopen(CfgFile,"r"); if(fil) { strcopy(buf,CfgFile); return(fil); } n = strncopy(buf,popt->home,MAXPFADLEN); buf[n] = SEP_DIR[0]; strncopy(buf+n+1,CfgFile,MAXPFADLEN-n); fil = fopen(buf,"r"); if(fil) return(fil); #ifdef genUNiX str = getenv("ARIRC"); if(str != NULL) { strncopy(buf,str,MAXPFADLEN); fil = fopen(buf,"r"); } if(fil) { return(fil); } #endif return(NULL); } /*------------------------------------------------------------------*/ PRIVATE int cfgfile(popt) struct options *popt; { FILE *fil; char linebuf[IOBUFSIZE+2]; char *str0, *str, *buf; int n, ch; fil = findcfg(popt); if(fil == NULL) { return(0); } while(fgets(linebuf,IOBUFSIZE,fil)) { str0 = trimblanks(linebuf,0); if(str0[0] == '-') { ch = toupcase(str0[1]); str = trimblanks(str0 + 2,1); switch(ch) { case 'M': popt->mem = str2int(str,&n); break; case 'C': popt->cols = str2int(str,&n); break; case 'P': buf = popt->pathbuf; strncopy(buf,str,MAXPFADLEN); popt->aripath = buf; break; case 'H': buf = popt->helpbuf; strncopy(buf,str,MAXPFADLEN); popt->helppath = buf; break; case 'Q': popt->verbose = 0; break; case 'V': popt->verbose = 1; break; case 'I': if(strcmp(str0,InitLabel) == 0) { popt->loadinit = popt->inibuf; } break; } } if(popt->loadinit) break; } fclose(fil); return 0; } /*------------------------------------------------------------------*/ PRIVATE int commandline(argc,argv,popt) int argc; char *argv[]; struct options *popt; { char *str, *buf; int ch; int n, k; k = 0; while(++k < argc && argv[k][0] == '-') { ch = argv[k][1]; str = argv[k] + 2; nochmal: switch(toupcase(ch)) { case 'M': /* memory for heap */ if(str[0] == 0 && k+1 < argc && argv[k+1][0] != '-') str = argv[++k]; popt->mem = str2int(str,&n); break; case 'C': /* columns */ if(str[0] == 0 && k+1 < argc && argv[k+1][0] != '-') str = argv[++k]; popt->cols = str2int(str,&n); break; case 'H': /* helppath */ if(str[0] == 0 && k+1 < argc && argv[k+1][0] != '-') str = argv[++k]; buf = popt->helpbuf; strncopy(buf,str,MAXPFADLEN); popt->helppath = buf; break; case 'P': /* aripath */ if(str[0] == 0 && k+1 < argc && argv[k+1][0] != '-') str = argv[++k]; buf = popt->pathbuf; strncopy(buf,str,MAXPFADLEN); popt->aripath = buf; break; case 'Q': popt->verbose = 0; if((ch = *str++)) goto nochmal; break; case 'V': popt->verbose = 1; if((ch = *str++)) goto nochmal; break; case 'B': /* batch mode */ popt->batchflg = 1; if((ch = *str++)) goto nochmal; break; default: ; } } if(k < argc) { popt->loadname = argv[k]; } popt->argc = argc - k; popt->argv = argv + k; return(argc); } /*------------------------------------------------------------------*/ PRIVATE int findhelpfile(popt) struct options *popt; { FILE *fil; char *searchpath; char path[MAXPFADLEN+2]; int n, erf; if(popt->helppath != NULL) { n = strcopy(path,popt->helppath); path[n] = SEP_DIR[0]; strncopy(path+n+1,HelpFile,MAXPFADLEN-n); fil = fopen(path,"r"); if(fil != NULL) { goto found; } else { path[n] = 0; fil = fopen(path,"r"); if((fil != NULL) && (getc(fil) > 0)) { goto found; } } } #ifdef genDOS if(strlen(popt->home) > 0) { n = strcopy(path,popt->home); path[n] = SEP_DIR[0]; strncopy(path+n+1,HelpFile,MAXPFADLEN-n); fil = fopen(path,"r"); if(fil != NULL) goto found; } #endif #ifdef genUNiX searchpath = getenv("PATH"); if(searchpath == NULL || *searchpath == 0) { goto notfound; } erf = findfile(searchpath,HelpFile,path); if(erf) { goto found1; } #endif notfound: popt->helppath = NULL; return(aERROR); found: fclose(fil); found1: strcopy(popt->helpbuf,path); popt->helppath = popt->helpbuf; return(0); } /*------------------------------------------------------------------*/ PRIVATE void initialize(popt) struct options *popt; { memalloc(popt->mem); inicont(); /* must be called first */ inialloc(); inistore(); inisyntchk(); iniarith(); inianalys(); inieval(); inifile(); iniarray(); initerm(); iniscan(); iniparse(); iniprint(popt->cols); inimain(popt); #ifdef MYFUN inimyfun(); #endif initend(); } /*------------------------------------------------------------------*/ PRIVATE void inimain(popt) struct options *popt; { int sflg; char *str; helpsym = newsymsig("help",sSBINARY, (wtruc)Shelp, s_01); if(popt->helppath != NULL) str = popt->helppath; else str = HelpFile; hlpfilsym = mksym(str,&sflg); if(popt->pathbuf != NULL) str = popt->pathbuf; else str = ""; apathsym = mksym(str,&sflg); res1sym = newsym("_", sSYSTEMVAR, zero); res1Ptr = SYMBINDPTR(&res1sym); res2sym = newsym("__", sSYSTEMVAR, zero); res2Ptr = SYMBINDPTR(&res2sym); res3sym = newsym("___",sSYSTEMVAR, zero); res3Ptr = SYMBINDPTR(&res3sym); haltsym = newsymsig("halt", sFBINARY, (wtruc)Fhalt, s_01); verssym = newsymsig("version", sFBINARY, (wtruc)Fversion, s_01); #ifdef DOSorUNiX systemsym = newsymsig("system",sFBINARY,(wtruc)Fsystem,s_1); getenvsym = newsymsig("getenv",sFBINARY,(wtruc)Fgetenv,s_1); #endif #ifdef TT ttsym = newsymsig("tt",sFBINARY,(wtruc)Ftt,s_0); #endif } /*------------------------------------------------------------------*/ #ifdef TT PRIVATE truc Ftt() { char *str; str = tmpnam(NULL); return(mkstr(str)); } #endif /* TT */ /*------------------------------------------------------------------*/ static char *gpltxt[] = { "ARIBAS comes with ABSOLUTELY NO WARRANTY. This is free software,", "and you are welcome to redistribute it under the terms of the GNU", "General Public License as published by the Free Software Foundation.\n", NULL }; /*------------------------------------------------------------------*/ PRIVATE void title() { s2form(OutBuf,"~%ARIBAS Interpreter for Arithmetic, ~A (~A)", strcast(Version),strcast(architec)); fprintline(tstdout,OutBuf); s2form(OutBuf,"Copyright (C) 1999-~A O.Forster <~A>", strcast(versionyear),strcast(Email)); fprintline(tstdout,OutBuf); displaypage(gpltxt); fnewline(tstdout); fnewline(tstdout); fprintline(tstdout,"for help, type\040\040?"); fprintline(tstdout,"to return from ARIBAS, type\040\040exit"); } /*------------------------------------------------------------------*/ PRIVATE int argload(fil,verb) char *fil; int verb; { char name[MAXPFADLEN+4]; int ret; ret = findarifile(fil,name); if(verb) { fnewline(tstdout); s1form(OutBuf,"(** loading ~A **)",strcast(name)); fprintline(tstdout,OutBuf); } ret = loadaux(name,verb,NULL); if(ret == aERROR) { s1form(OutBuf,"error while loading file ~A",strcast(name)); fprintline(tstderr,OutBuf); } return(ret); } /*------------------------------------------------------------------*/ PRIVATE int mainloop() { static char resprompt[] = "-: "; truc obj; int jres; setjumpflg = 1; for( ; ; ) { jres = setjmp(globenv); if(jres == HALTRET) { obj = haltret; goto printres; } if(STREAMtok(tstdin) == EOLTOK || jres) { inputprompt(); } obj = tread(&tstdin,TERMINALINP); if(obj == exitsym || obj == eofsym) break; if(obj == historsym) { historyout(1); continue; } flinepos0(tstdout); obj = eval(&obj); printres: toprespush(obj); if(obj == breaksym) { if(*brkmodePtr == exitsym) break; else obj = errsym; } ffreshline(tstdout); if(obj != voidsym) { fprintstr(tstdout,resprompt); tprint(tstdout,obj); fnewline(tstdout); } } return(mainret); } /*------------------------------------------------------------------*/ PRIVATE void toprespush(obj) truc obj; { *res3Ptr = *res2Ptr; *res2Ptr = *res1Ptr; *res1Ptr = obj; } /*------------------------------------------------------------------*/ PRIVATE truc Fversion(argn) int argn; { if(argn == 0 || *argStkPtr != zero) { s2form(OutBuf,"ARIBAS Version ~A (~A)", strcast(Version),strcast(architec)); fprintline(tstdout,OutBuf); } return(mkfixnum(version_no)); } /*------------------------------------------------------------------*/ #ifdef DOSorUNiX PRIVATE truc Fsystem() { char command[MAXCMDLEN+2]; int res; if(*FLAGPTR(argStkPtr) != fSTRING) { error(systemsym,err_str,*argStkPtr); goto errexit; } if(tempfree(1) == 0) { error(systemsym,err_memev,voidsym); goto errexit; } strncopy(command,STRINGPTR(argStkPtr),MAXCMDLEN); res = system(command); if(tempfree(0) == 0) { mainret = error(scratch("\nFATAL ERROR"),err_memory,voidsym); return(Sexit()); } return(mksfixnum(res)); errexit: return(mksfixnum(-1)); } #endif /*------------------------------------------------------------------*/ #ifdef DOSorUNiX PRIVATE truc Fgetenv() { char *estr; if(*FLAGPTR(argStkPtr) != fSTRING) { error(getenvsym,err_str,*argStkPtr); return(brkerr()); } estr = getenv(STRINGPTR(argStkPtr)); if(estr == NULL) { return(nullstring); } else { return(mkstr(estr)); } } #endif /*------------------------------------------------------------------*/ PUBLIC int error(source,message,obj) truc source; char *message; truc obj; { if(source != voidsym) { tprint(tstderr,source); fprintstr(tstderr,": "); } fprintstr(tstderr,message); if(obj != voidsym) { fprintstr(tstderr,": "); tprint(tstderr,obj); } fnewline(tstderr); return(aERROR); } /*------------------------------------------------------------------*/ PRIVATE truc Fhalt(argn) int argn; { if(argn == 1 && *FLAGPTR(argStkPtr) == fFIXNUM) haltret = *argStkPtr; else haltret = zero; resetarr(); if(setjumpflg) longjmp(globenv,HALTRET); else exit(-2); return(haltret); } /*------------------------------------------------------------------*/ PUBLIC void setinterrupt(flg) int flg; { Unterbrech = flg; } /*------------------------------------------------------------------*/ #ifdef DOSorUNiX PUBLIC void ctrlcreset(sig) int sig; { signal(sig,SIG_IGN); #ifdef UNiXorGCC setinterrupt(1); signal(SIGINT,ctrlcreset); #else resetcleanup("interrupted by CTRL-C"); signal(SIGINT,ctrlcreset); if(setjumpflg) longjmp(globenv,RESET); else exit(-2); #endif /* ?genUNiX */ } #endif /* DOSorUNiX */ /*------------------------------------------------------------------*/ PRIVATE void resetcleanup(message) char *message; { *brkbindPtr = zero; resetarr(); clearcompile(); historyout(0); fnewline(tstderr); fprintline(tstderr,message); fprintline(tstderr,"** RESET **"); } /*------------------------------------------------------------------*/ PUBLIC void reset(message) char *message; { resetcleanup(message); if(setjumpflg) longjmp(globenv,RESET); else exit(-2); } /*------------------------------------------------------------------*/ PUBLIC void faterr(mess) char *mess; { fputs("\n FATAL ERROR: ",stderr); fputs(mess,stderr); fputs("\n",stderr); exit(aERROR); } /*------------------------------------------------------------------*/ /********************************************************************/ /* ** Text for help introduction */ static char *help1txt[] = { "The simplest way to use ARIBAS is as a calculator for big integer arithmetic", "\t+, -, *\t have the usual meaning", "\t**\t denotes exponentiation", "\tdiv, mod calculate the quotient resp. remainder of integer division", "\t/\t denotes floating point division", "Simply enter the expression you want to calculate at the ARIBAS prompt ==>", "followed by a full stop, for example", "\t==> (23*57 - 13) div 7.", "After pressing RETURN, the result (here 185) will appear.", "You can also assign the result of a calculation to a variable, as in", "\tp := 2**127 - 1.", "and later use this variable, for example", "\tx := 1234**(p-1) mod p.", "The three most recent results are stored in the pseudo variables", "_, __, and ___. Suppose you have calculated", "\t==> sqrt(2).", "\t-: 1.41421356", "Then you can use the result at the next prompt for example in the", "expression arcsin(_/2).", "IMPORTANT: To mark the end of your input, you must type a full stop '.'", "\t and then press the RETURN (ENTER) key.\n", NULL}; /*------------------------------------------------------------------*/ static char *help2txt[] = { "The for loop and while loop in ARIBAS have a syntax similar to", "MODULA-2. For example, the sequence", "\tx := 1;", "\tfor i := 2 to 100 do", "\t x := x*i;", "\tend;", "\tx.", "calculates the factorial of 100.", "You can define your own functions in ARIBAS. For example, a recursive", "version of the factorial function can be defined by", "\tfunction fac(n: integer): integer;", "\tbegin", "\t if n <= 1 then", "\t\treturn 1;", "\t else", "\t\treturn n*fac(n-1);", "\t end;", "\tend.", "After you have entered this, the function fac will be at your disposal and", "\t==> fac(100).", "will calculate the factorial of 100.\n", NULL}; /*------------------------------------------------------------------*/ static char *help3txt[] = { "A list of all keywords and names of builtin functions is returned", "by the command\n", "\t==> symbols(aribas).\n", "For most of the symbols in this list, you can get a short online", "help using the help function. For example\n", "\t==> help(factor16).\n", "will print an information on the function factor16 to the screen.\n", "For more information, read the documentation.\n", "To leave ARIBAS, type\040\040exit", NULL}; /*------------------------------------------------------------------*/ PRIVATE truc Shelp() { truc *ptr; char *topic; int argn; argn = *ARGCOUNTPTR(evalStkPtr); if(argn >= 1) { ptr = ARG1PTR(evalStkPtr); if(*FLAGPTR(ptr) == fSYMBOL) { topic = SYMNAMEPTR(ptr); helptopic(topic); return(voidsym); } } helpintro(); return(voidsym); } /*------------------------------------------------------------------*/ PRIVATE int helpintro() { static char *gotonext = "Press RETURN to see the next help screen."; displaypage(help1txt); fnewline(tstdout); fprintstr(tstdout,gotonext); fflush(stdout); getchar(); displaypage(help2txt); fnewline(tstdout); fprintstr(tstdout,gotonext); fflush(stdout); getchar(); displaypage(help3txt); return(0); } /*------------------------------------------------------------------*/ PRIVATE void displaypage(txtarr) char *txtarr[]; { char *str; int i = 0; while((str = txtarr[i]) != NULL) { fnewline(tstdout); fprintstr(tstdout,str); i++; } } /*------------------------------------------------------------------*/ #define TOPICMARKER '?' #define TOPICEND '#' #define PAGEFULL 25 PRIVATE int helptopic(topic) char *topic; { FILE *hfile; char *path; int i, len; int found = 0; path = SYMname(hlpfilsym); hfile = fopen(path,"r"); if(hfile == NULL) { error(helpsym,err_open,scratch(path)); return(aERROR); } len = strlen(topic); while(fgets(OutBuf,IOBUFSIZE,hfile)) { if(OutBuf[0] == TOPICMARKER && strncmp(OutBuf+1,topic,len) == 0 && OutBuf[len+1] <= ' ') { found = 1; break; } } if(found) { while(fgets(OutBuf,IOBUFSIZE,hfile) && OutBuf[0] == TOPICMARKER) ; fprintstr(tstdout,OutBuf); for(i=0; i # date: 2007-08-23 ############################################################# #CC = cc #CFLAGS = -DUNiX -O # for some compilers it might be necessary to remove the -O flag # If you have the GNU gcc compiler on your system, you may wish # to use gcc. Then outcomment the first two lines and activate # the next two lines. CC = gcc CFLAGS = -DUNiX -DPROTO -O -v MEMFLAG1 = -DMEM=16 # MEM may be set to any integer value from 1 to 32. # This is the size of the ARIBAS heap in Megabytes # The value should not exceed one half of the RAM of your machine # If MEMFLAG is not defined, MEM=4 will be used by default MEMFLAG2 = -DINTSIZE=64 # INTSIZE may be set to any value from 20 to 300. # Then ARIBAS can work with integers up to # INTSIZE*1000 decimal places MEMFLAG = $(MEMFLAG1) $(MEMFLAG2) OBJECTS = alloc.o analysis.o aritaux.o arith.o aritool0.o \ aritools.o aritx.o arity.o aritz.o array.o control.o \ errtext.o eval.o file.o mainloop.o mem0.o parser.o print.o \ scanner.o storage.o syntchk.o sysdep.o terminal.o PROGRAM = aribas all: $(PROGRAM) $(OBJECTS): common.h terminal.o: logscr.inc .c.o: $(CC) $(CFLAGS) -c $< alloc.o: alloc.c common.h $(CC) $(CFLAGS) $(MEMFLAG) -c alloc.c $(PROGRAM): $(OBJECTS) $(CC) -o $(PROGRAM) $(OBJECTS) strip $(PROGRAM) clean: \rm *.o ############################ EOF ############################## aribas165b/src/mem0.c0000644000076600000240000000526214660570647013403 0ustar ottostaff/****************************************************************/ /* file mem0.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** mem0.c ** Entschluesselung der truc's zu echten Pointern ** Kann zur Beschleunigung in Assembler geschrieben werden ** ** date of last change ** 1994-02-15 ** 2013-07-15 */ #include "common.h" PUBLIC truc *Taddress (truc x); PUBLIC truc *Saddress (truc x); PUBLIC truc *TAddress (truc *p); PUBLIC truc *SAddress (truc *p); PUBLIC int Tflag (truc x); PUBLIC int Symflag (truc x); /*----------------------------------------------------------------*/ PUBLIC truc *Taddress(x) truc x; { variant v; size_t offs; v.xx = x; offs = v.pp.ww; return(Memory[v.pp.b1] + offs); } /*----------------------------------------------------------------*/ PUBLIC truc *Saddress(x) truc x; { variant v; size_t offs; v.xx = x; offs = v.pp.ww; return(Symbol + offs); } /*----------------------------------------------------------------*/ PUBLIC truc *TAddress(p) truc *p; { variant v; size_t offs; v.xx = *p; offs = v.pp.ww; return(Memory[v.pp.b1] + offs); } /*----------------------------------------------------------------*/ PUBLIC truc *SAddress(p) truc *p; { size_t offs; offs = *((word2 *)p + 1); return(Symbol + offs); } /*----------------------------------------------------------------*/ PUBLIC int Tflag(x) truc x; { variant v; v.xx = x; return(v.pp.b0); } /*-------------------------------------------------------------*/ PUBLIC int Symflag(x) truc x; { variant v; size_t offs; v.xx = x; offs = v.pp.ww; return(*(byte *)(Symbol + offs)); } /*-------------------------------------------------------------*/ /***************************************************************/ aribas165b/src/parser.c0000644000076600000240000020437414660570650014040 0ustar ottostaff/****************************************************************/ /* file parser.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** parser.c ** parser ** ** date of last change ** 1995-02-22 lpbrksym ** 1995-03-11 fixed problems with tread ** 1995-03-20 const, type ** 1995-03-29 record, pointer to ** 1997-04-13 type symbol, reorg (newintsym) ** 1998-10-07 continue statement ** 2001-03-11 improved some error messages ** 2002-02-16 uminsym in negate ** 2002-02-24 Z1TOK ** 2003-02-27 enddotsym ** 2004-06-13 better error handling in readwhile, readif; ARGLIST ** 2004-08-27 removed bug in previous handling of ARGLIST ** 2004-12-27 changed recoverr (handle EOF) */ #include "common.h" PUBLIC void iniparse (void); PUBLIC truc tread (truc *strom, int mode); PUBLIC void clearcompile (void); PUBLIC truc parserrsym; /*------------------------------------------------------------*/ PRIVATE int operprec (int tok); PRIVATE int rightass (int tok); PRIVATE int binop (int tok); PRIVATE truc readexpr (truc *strom, int prec); PRIVATE truc optbnode (truc op); PRIVATE truc primary (truc *strom, int *cflgptr); PRIVATE int parsedsym (char *name, truc *pobj); PRIVATE truc prochistory (char *sbuf, truc *strom); PRIVATE truc readwrite (truc wsym, truc *strom); PRIVATE truc readformat (truc *strom, int *tokptr); PRIVATE truc readvector (int flg, truc *strom); PRIVATE truc readbrack (truc *strom, int *pmode); PRIVATE truc funcall (truc fun, truc *strom); PRIVATE truc arraccess (truc arr, truc *strom); PRIVATE truc recaccess (truc arr, truc *strom); PRIVATE truc compfunc (truc *strom); PRIVATE truc varssyms (truc symbs); PRIVATE void vars2push (truc symbs); PRIVATE truc getfuname (truc *strom); PRIVATE int markparms (truc symbs, truc kind); PRIVATE int marksymbs (truc symbs); PRIVATE int markglobs (truc symbs); PRIVATE void unmarksymbs (truc symbs); PRIVATE truc parmlist (truc *strom, int *vflgptr, int *optcptr); PRIVATE truc varlist (truc *strom, truc *endptr); PRIVATE truc lconstlist (truc *strom, truc *endptr); PRIVATE int varsection (truc *strom, truc *endptr); PRIVATE int parmsection (truc *strom, truc *endptr, int *vflgptr); PRIVATE int parmsaux (truc *strom, truc *typptr, truc *endptr, int *ofp); PRIVATE int varsaux (int tok, truc *strom, truc *typptr, truc *endptr); PRIVATE truc typespec (truc *strom); PRIVATE truc pointertype (truc *strom); PRIVATE truc ptrtypeval (truc typ); PRIVATE truc globconstdef (truc *strom); PRIVATE truc globtypedef (truc *strom); PRIVATE truc globvardef (truc *strom); PRIVATE int decldelim (truc delim); PRIVATE int arglist (truc *strom, int endtok); PRIVATE truc readrecdef (truc *strom); PRIVATE truc readwhile (truc *strom); PRIVATE truc readfor (truc *strom); PRIVATE int obligsym (truc fun, truc *strom, truc symb); PRIVATE void errexpect (truc fun, truc symb, truc esym); PRIVATE int statements (truc *strom, truc *endptr); PRIVATE truc readif (truc *strom); PRIVATE truc negate (truc obj); PRIVATE void recoverr (truc *strom); PRIVATE int pstat (int mode, unsigned flag); PRIVATE truc tmptoksym (int tok); PRIVATE truc scansym, enddotsym; PRIVATE unsigned locsymbs = 0; // #define PARSLOG #ifdef PARSLOG char *plogfile = "pars.log"; FILE *Plog = NULL; int plogtruc(obj) truc obj; { fprintf(Plog,"%04X\n",(word4)obj); return 0; } int plognum(n) int n; { fprintf(Plog,"%d\n",n); return 0; } int plogmess(mess) char *mess; { fprintf(Plog,"%s\n",mess); return strlen(mess); } #endif /*--------------------------------------------------------------------*/ PUBLIC void iniparse() { parserrsym = newselfsym("syntax error",sINTERNAL); scansym = newselfsym("scanning",sINTERNAL); enddotsym = newselfsym(".",sINTERNAL); } /*--------------------------------------------------------------------*/ /* ** Funktion zur Verwaltung des Pars-Status */ #define PQUERY 1 #define PSET 2 #define PCLEAR 3 #define PCLEARALL 4 #define COMPILING 0x01 #define CONSTDECL 0x02 #define EXTERNDECL 0x04 #define POINTRECURS 0x08 #define PLAINSYM 0x10 #define ARGLIST 0x20 #define ALLFLAG 0xFFFF PRIVATE int pstat(mode,flag) int mode; unsigned flag; { static unsigned pstatus = 0; switch(mode) { case PQUERY: return(pstatus & flag); case PSET: return(pstatus |= flag); case PCLEAR: return(pstatus &= ~flag); case PCLEARALL: pstatus = 0; return(0); default: return(pstatus); } } /*--------------------------------------------------------------------*/ /* ** operator precedence */ #define POWERPREC 3000 #define UMINUSPREC 2500 #define MULTPREC 2000 #define ADDPREC 1000 #define RELPREC 500 #define NOTPREC 400 #define ANDPREC 300 #define ORPREC 200 #define ASSIGNPREC 10 PRIVATE int operprec(tok) int tok; { if(tok >= PLUSTOK) { if(tok <= MINUSTOK) return(ADDPREC); if(tok <= MODTOK) return(MULTPREC); if(tok == UMINUSTOK) return(UMINUSPREC); if(tok == POWERTOK) return(POWERPREC); } else if(tok >= EQTOK) /* relational ops */ return(RELPREC); else switch(tok) { case ASSIGNTOK: return(ASSIGNPREC); case ANDTOK: return(ANDPREC); case ORTOK: return(ORPREC); case NOTTOK: return(NOTPREC); } rerror(parserrsym,err_case,mkfixnum(tok)); return(0); } /*--------------------------------------------------------------------*/ /* ** returns associativity of operator (left = 0, right = 1) */ PRIVATE int rightass(tok) int tok; { return(tok & 1); } /*--------------------------------------------------------------------*/ /* ** returns 1 if tok is binary operator, else 0 */ PRIVATE int binop(tok) int tok; { if(tok >= EQTOK && tok <= MODTOK) return(1); else if(tok >= ASSIGNTOK && tok <= ANDTOK) return(1); else if(tok == POWERTOK) return(1); else return(0); } /*--------------------------------------------------------------------*/ #define READBUFSIZE 64 /* ** Read expressions from strom ** Expressions are buffered ** If mode == TERMINALINP, returns if DOTTOK is encountered ** (called from mainloop) ** if mode == FILEINPUT, returns if EOLTOK is encountered after ** a complete expression ** (called from loadaux, used by ARIBAS function load) ** Before returning, all but the last expressions are evaluated ** The last expression read is returned ** Place strom should be protected w/r to garbage collection */ PUBLIC truc tread(strom,mode) truc *strom; int mode; /* mode = TERMINALINP or FILEINPUT */ { truc *arr; truc obj; int tok; int count = 0; arr = workStkPtr; while(++count <= READBUFSIZE) { obj = readexpr(strom,0); if(obj == parserrsym || obj == breaksym) { recoverr(strom); obj = brkerr(); goto cleanup; } WORKpush(obj); if(obj == exitfun) { break; } if(mode == TERMINALINP) { if(obj == historsym) { if(count != 1) { rerror(parserrsym,"",historsym); obj = brkerr(); goto cleanup; } break; } tok = skipeoltok(strom); if(tok == SEMICOLTOK) { tok = nexttok(strom,0); } else if(tok == DOTTOK || tok == QUESTIONTOK) { tok = nexttok(strom,0); break; } } else { /* FILEINPUT */ /**************************/ if((tok = curtok(strom)) != SYMBOLTOK) tok = nexttok(strom,0); if(tok == EOLTOK || tok == EOFTOK) break; } } if(arreval(arr+1,count-1) == breaksym) { obj = brkerr(); goto cleanup; } obj = *workStkPtr; cleanup: workStkPtr = arr; return(obj); } #undef READBUFSIZE /*--------------------------------------------------------------------*/ PRIVATE truc readexpr(strom,prec) truc *strom; int prec; { truc obj, obj1, op; int tok, sflg; int prec1; int complete; #ifdef PARSLOG int tok0; #endif obj = primary(strom,&complete); #ifdef PARSLOG plogmess("Inside readexpr, after primary"); #endif if(complete || obj == parserrsym) { #ifdef PARSLOG plogmess("complete, obj = "); plogtruc(obj); #endif return(obj); } while(1) { #ifdef PARSLOG tok0 = curtok(strom); #endif tok = skipeoltok(strom); #ifdef PARSLOG plogmess("readexpr, inside while loop, obj, tok0, tok = "); plogtruc(obj); plognum(tok0); plognum(tok); #endif if(tok == SYMBOLTOK) { sflg = lookupsym(SymBuf,&obj1); /* look for infix operator mod, div, and, or .. */ if(sflg == sINFIX) { tok = tokenvalue(obj1); op = SYMbind(obj1); } else { #ifdef PARSLOG plogmess("breakpoint 1, Symbuf, curtok = "); plogmess(SymBuf); plognum(curtok(strom)); #endif break; } } else if(binop(tok)) { op = Curop; /* from scanner */ } else if(tok == LPARENTOK) { if(obj == helpsym) { pstat(PSET,PLAINSYM); obj = funcall(obj,strom); pstat(PCLEAR,PLAINSYM); } else { obj = funcall(obj,strom); } continue; } else if(tok == LBRACKTOK) { obj = arraccess(obj,strom); continue; } else if(tok == RECDOTTOK) { obj = recaccess(obj,strom); continue; } else if(tok == DEREFTOK) { PARSpush(obj); obj = mkunode(derefsym); PARSpop(); tok = nexttok(strom,1); continue; } else if(tok == SEMICOLTOK || tok == DOTTOK || tok == EOFTOK) { break; } else { #ifdef PARSLOG plogmess("breakpoint 2, curtok = "); plognum(curtok(strom)); #endif break; } prec1 = operprec(tok); if(prec1 < prec) break; else if(prec1 == prec) { if(prec == RELPREC) { /* Fehler-Behandlung noch mangelhaft */ rerror(parserrsym,"RELPREC",Curop); obj = parserrsym; break; } else if(!rightass(tok)) break; } PARSpush(obj); nexttok(strom,0); obj = readexpr(strom,prec1); if(obj == parserrsym || obj == breaksym) { PARSpop(); break; } PARSpush(obj); obj = optbnode(op); PARSnpop(2); } #ifdef PARSLOG plogmess("exiting readexpr, obj = "); plogtruc(obj); #endif return(obj); } /*--------------------------------------------------------------------*/ #define isCONSTANT(p) (*FLAGPTR(p) >= fCONSTLIT) /*--------------------------------------------------------------------*/ PRIVATE truc optbnode(op) truc op; { truc obj, sym, sym1; truc *ptr; int doopt; if(op == modsym) { /* Erkennt einen Ausdruck der Form Base ** Expo mod Modul ** und stellt einen Knoten modpower(Base,Expo,Modul) her ** Analog fuer pol_mult(P1,P2) mod N */ if(*FLAGPTR(argStkPtr-1) == fBUILTIN2) { doopt = 0; ptr = TAddress(argStkPtr-1); sym = *ptr; if(sym == powersym) { doopt = 1; sym1 = modpowsym; } #ifdef POLYARITH else if(sym == polmultsym) { doopt = 1; sym1 = polNmultsym; } else if(sym == polmodsym) { doopt = 1; sym1 = polNmodsym; } else if(sym == poldivsym) { doopt = 1; sym1 = polNdivsym; } #endif /* POLYARITH */ if(doopt) { obj = *argStkPtr; /* Modul */ argStkPtr[-1] = ptr[1]; /* arg1 */ *argStkPtr = ptr[2]; /* arg2 */ PARSpush(obj); obj = mkfunode(sym1,3); PARSpop(); return(obj); } } } /* Binaere Ausdruecke mit konstanten Operanden ** werden ausgewertet */ if(op != powersym && isCONSTANT(argStkPtr-1) && isCONSTANT(argStkPtr)) { *argStkPtr = mkbnode(op); return(eval(argStkPtr)); } return(mkbnode(op)); } /*--------------------------------------------------------------------*/ /* ** read a primary expression from strom */ PRIVATE truc primary(strom,cflgptr) truc *strom; int *cflgptr; { truc obj; int tok, weiter = 1; int sflg; *cflgptr = 0; #ifdef PARSLOG if (Plog == NULL) Plog = fopen(plogfile,"w"); #endif nochmal: tok = skipeoltok(strom); switch(tok) { case SYMBOLTOK: #ifdef PARSLOG plogmess("inside primary, SymBuf = "); plogmess(SymBuf); #endif sflg = parsedsym(SymBuf,&obj); if(sflg == aERROR) { obj = parserrsym; } else if(sflg == sPARSAUX) { if(obj == whilesym) { obj = readwhile(strom); *cflgptr = 1; } else if(obj == ifsym) { obj = readif(strom); *cflgptr = 1; } else if(obj == forsym) { obj = readfor(strom); *cflgptr = 1; } else if(obj == funcsym || obj == procsym) { if (pstat(PQUERY,ARGLIST) == ARGLIST) { obj = funcsym; nexttok(strom,0); } else { obj = compfunc(strom); } *cflgptr = 1; } else if(obj == varsym) { obj = globvardef(strom); *cflgptr = 1; } else if(obj == constsym) { obj = globconstdef(strom); *cflgptr = 1; } else if(obj == typesym) { obj = globtypedef(strom); *cflgptr = 1; } else if(obj == notsym) { nexttok(strom,0); obj = readexpr(strom,NOTPREC); /* Fehlerbehandlung fehlt */ PARSpush(obj); obj = mkunode(not_sym); PARSpop(); } else if(obj == retsym) { nexttok(strom,0); obj = readexpr(strom,0); /* Fehlerbehandlung fehlt */ PARSpush(obj); obj = mkunode(ret_sym); PARSpop(); *cflgptr = 1; } else if(obj == exitsym) { nexttok(strom,0); obj = exitfun; *cflgptr = 1; } else if(obj == lpbrksym) { nexttok(strom,0); obj = lpbrkfun; *cflgptr = 1; } else if(obj == lpcontsym) { nexttok(strom,0); obj = lpcontfun; *cflgptr = 1; } else if(obj == writesym || obj == writlnsym) { tok = nexttok(strom,0); if(tok != LPARENTOK) { rerror(obj,err_0lparen,voidsym); obj = parserrsym; } else { obj = readwrite(obj,strom); *cflgptr = 1; } } else { rerror(parserrsym,"",obj); obj = parserrsym; } return(obj); } else if(sflg == sEXTFUNCTION) { /* external function, during compiling */ tok = nexttok(strom,1); if(tok != LPARENTOK) { rerror(funcsym,err_unvar,obj); return(parserrsym); } else weiter = 0; } break; case INUMTOK: obj = mkint(Curnum.sign,Curnum.digits,Curnum.len); #ifdef PARSLOG plogmess("inside primary, inum ="); plognum((int)Curnum.digits[0]); #endif break; case GF2NTOK: obj = mkgf2n(Curnum.digits,Curnum.len); break; case FLOATTOK: obj = mkfloat(fltreadprec(),&Curnum); break; case CHARTOK: obj = mkchar(StrBuf[0]); break; case STRINGTOK: obj = mkstr(StrBuf); break; case BSTRINGTOK: obj = mkbstr((byte*)Curnum.digits,Curnum.len); break; case LPARENTOK: case LBRACETOK: obj = readvector(tok,strom); weiter = 0; break; case PLUSTOK: /* skip unary + */ nexttok(strom,1); goto nochmal; case MINUSTOK: nexttok(strom,0); obj = readexpr(strom,operprec(UMINUSTOK)); obj = negate(obj); weiter = 0; break; case SEMICOLTOK: obj = voidsym; *cflgptr = 1; break; case RPARENTOK: case RBRACETOK: rerror(parserrsym,err_rparen,voidsym); obj = parserrsym; break; case HISTORYTOK: obj = prochistory(SymBuf,strom); *cflgptr = 1; break; case QUESTIONTOK: if(pstat(PQUERY,COMPILING)) { nexttok(strom,1); goto nochmal; } obj = mkfunode(helpsym,0); weiter = 0; *cflgptr = 1; break; case DOTTOK: obj = enddotsym; *cflgptr = 1; weiter = 0; break; case Z1TOK: *cflgptr = 1; error(scansym,"input too long",bufovflsym); obj = brkerr(); break; case EOFTOK: obj = eofsym; weiter = 0; break; default: rerror(parserrsym,"while parsing",tmptoksym(tok)); /****************************/ obj = parserrsym; } if(weiter) nexttok(strom,0); return(obj); } /*--------------------------------------------------------------*/ PRIVATE int parsedsym(name,pobj) char *name; truc *pobj; { struct symbol *sptr; truc obj; unsigned n; int sflg; obj = mksym(name,&sflg); if(pstat(PQUERY,PLAINSYM)) sflg = sVARIABLE; if(pstat(PQUERY,COMPILING) && sflg < sFBINARY) { n = SYMcc0(obj); if(n == mGLOBAL) { if(sflg == sCONSTANT) { sptr = symptr(obj); obj = sptr->bind.t; } } else if(n & mGLOBAL) { /* obj is a reference variable */ n &= ~mGLOBAL; obj = mklocsym(fRSYMBOL,n-1); } else if(n >= mLOCCONST) { n -= mLOCCONST; obj = mklocsym(fTMPCONST,n); if(!pstat(PQUERY,CONSTDECL)) { obj = Lconsteval(&obj); } } else if(n) { /* obj is a local variable */ obj = mklocsym(fLSYMBOL,n-1); } else if(sflg != sFUNCTION) { /* identifier must be an external, not yet defined function ** otherwise generates syntax error */ sflg = sEXTFUNCTION; } } *pobj = obj; return(sflg); } /*--------------------------------------------------------------*/ /* ** process commandline of the form !, !!, !!!, !a, !b, !c. */ PRIVATE truc prochistory(sbuf,strom) char *sbuf; truc *strom; { int tok, ind, ch; ch = sbuf[1]; if('a' <= ch && ch <= 'c') ind = ch; else ind = strlen(sbuf); /* ** Indices: ! = 1, !! = 2, !!! = 3, !a = 'a', !b = 'b', !c = 'c' ** used by function historydisp() in module terminal.c */ tok = nexttok(strom,0); if(tok == EOLTOK) { SYMbind(historsym) = mkfixnum(ind); return(historsym); } else return(brkerr()); } /*--------------------------------------------------------------*/ /* ** Lese Argument-Liste fuer write und writeln-Funktion */ PRIVATE truc readwrite(wsym,strom) truc wsym; /* writesym or writlnsym */ truc *strom; { truc *savptr; truc fun; truc obj; int tok, chk; int n = 0; savptr = argStkPtr; tok = nexttok(strom,1); /* ueberlese linke Klammer */ while(tok != RPARENTOK) { obj = readexpr(strom,0); if(obj == parserrsym) goto cleanup; else { PARSpush(obj); n++; } tok = skipeoltok(strom); if(tok == COLONTOK) { obj = readformat(strom,&tok); if(obj == parserrsym) goto cleanup; PARSpush(obj); obj = mkbnode(formatsym); PARSpop(); *argStkPtr = obj; } if(tok == COMMATOK) nexttok(strom,1); else if(tok != RPARENTOK) { rerror(parserrsym,err_0rparen,voidsym); obj = parserrsym; goto cleanup; } } nexttok(strom,0); fun = SYMbind(wsym); /* write_sym or writln_sym */ chk = chknargs(fun,n); if(chk == NARGS_VAR) obj = mkfunode(fun,n); else { rerror(fun,err_args,voidsym); obj = parserrsym; } cleanup: argStkPtr = savptr; return(obj); } /*--------------------------------------------------------------*/ /* ** Lese Format-Angaben in write- oder writeln-Funktion ** nach dem Doppelpunkt */ PRIVATE truc readformat(strom,tokptr) truc *strom; int *tokptr; { truc *arr; truc obj; int m = 0; arr = workStkPtr + 1; while(*tokptr == COLONTOK) { nexttok(strom,1); obj = readexpr(strom,0); if(obj == parserrsym) goto cleanup; WORKpush(obj); m++; *tokptr = skipeoltok(strom); } obj = mkntuple(fTUPLE,arr,m); cleanup: workStkPtr = arr - 1; return(obj); } /*--------------------------------------------------------------*/ /* ** read vector or parentized expression */ PRIVATE truc readvector(flg,strom) int flg; /* flg == LPARENTOK or LBRACETOK */ truc *strom; { truc obj; int endtok; int n; endtok = (flg == LBRACETOK ? RBRACETOK : RPARENTOK); n = arglist(strom,endtok); if(n == aERROR) obj = parserrsym; else if(n == 1 && flg == LPARENTOK) obj = PARSretr(); else { obj = mkfunode(vectorsym,n); PARSnpop(n); } return(obj); } /*--------------------------------------------------------------*/ /* ** read expression between [ and ] ** either [] (*pmode = 0) ** or [ .. ] (*pmode = 1) */ PRIVATE truc readbrack(strom,pmode) truc *strom; int *pmode; { truc obj; int tok; nexttok(strom,0); /* ueberlese linke Klammer */ obj = readexpr(strom,0); tok = skipeoltok(strom); if(tok == RBRACKTOK) { *pmode = 0; goto ausgang; } else if(tok == DOTDOTTOK) { *pmode = 1; PARSpush(obj); tok = nexttok(strom,1); /* ueberlese .. */ if(tok == RBRACKTOK) { PARSpush(endsym); } else { obj = readexpr(strom,0); PARSpush(obj); tok = skipeoltok(strom); } if(tok == RBRACKTOK) { obj = mkbnode(pairsym); PARSnpop(2); goto ausgang; } else { PARSnpop(2); goto errexit; } } errexit: /* genauere Fehlermeldung wuenschenswert */ rerror(parserrsym,err_0rbrack,voidsym); return(parserrsym); ausgang: nexttok(strom,0); return(obj); } /*--------------------------------------------------------------*/ /* ** parse function call */ PRIVATE truc funcall(fun,strom) truc fun; truc *strom; { truc obj; int n, chk; /* ? check function name !!! */ /*** case of functions as local variables ? ****/ if(Tflag(fun) == fSYMBOL && Symflag(fun) == sTYPESPEC) { if(fun == bstringsym) { fun = bstr_sym; } else if(fun == integsym) { fun = int_sym; } else if(fun == stringsym) { fun = str_sym; } else if(fun == gf2nintsym) { fun = gf2n_sym; } else { rerror(voidsym,err_funame,fun); return(parserrsym); } } n = arglist(strom,RPARENTOK); if(n == aERROR) return(parserrsym); chk = chknargs(fun,n); if(chk == NARGS_OK) { if(n == 1) obj = mkunode(fun); else if(n == 2) obj = mkbnode(fun); else if(n == 0) obj = mk0fun(fun); else obj = mkfunode(fun,n); } else if(chk == NARGS_VAR) obj = mkfunode(fun,n); else { rerror(fun,err_args,voidsym); obj = parserrsym; } PARSnpop(n); return(obj); } /*--------------------------------------------------------------*/ PRIVATE truc arraccess(arr,strom) truc arr; truc *strom; { truc obj; truc sym; int mode; /* ? check array name !!! */ PARSpush(arr); obj = readbrack(strom,&mode); if(obj != parserrsym) { sym = (mode == 0 ? arr_sym : subarrsym); PARSpush(obj); obj = mkbnode(sym); PARSpop(); } PARSpop(); return(obj); } /*--------------------------------------------------------------*/ PRIVATE truc recaccess(rr,strom) truc rr; truc *strom; { truc obj; int tok; PARSpush(rr); tok = nexttok(strom,0); /* ueberlese dot */ if(tok != SYMBOLTOK || lookupsym(SymBuf,&obj) == aERROR) { rerror(recordsym,err_field,voidsym); obj = parserrsym; goto ausgang; } nexttok(strom,0); PARSpush(obj); obj = mkbnode(rec_sym); PARSpop(); ausgang: PARSpop(); return(obj); } /*--------------------------------------------------------------*/ /* ** parse function definition */ PRIVATE truc compfunc(strom) truc *strom; { struct symbol *sptr; truc *parssav, *worksav; truc fun, parms, typ, globs, consts, vars, delim, body; truc obj = parserrsym; int tok, sflg, vflg; int numstats; int numparms = 0, numvars = 0, numopts = 0; int errflg = 0; if(pstat(PQUERY,COMPILING)) { rerror(parserrsym,err_funest,voidsym); goto ausgang; } else pstat(PSET,COMPILING); parssav = argStkPtr; worksav = workStkPtr; /******** function head *********/ fun = getfuname(strom); if(fun == parserrsym) goto ausgang; parms = parmlist(strom,&vflg,&numopts); if(parms == parserrsym) goto ausgang; vars2push(parms); numparms = markparms(*workStkPtr,*argStkPtr); if(numparms == aERROR) goto cleanup1; tok = skipeoltok(strom); if(tok == COLONTOK) { /* return type of function */ typ = typespec(strom); if(typ == parserrsym) goto cleanup1; tok = skipeoltok(strom); /****** no action taken in this version ******/ } if(tok == SEMICOLTOK) { tok = nexttok(strom,1); } /******** declaration of global variables *********/ if(tok != SYMBOLTOK || lookupsym(SymBuf,&delim) == aERROR) { rerror(funcsym,err_synt,voidsym); goto cleanup1; } if(delim == extrnsym) { pstat(PSET,EXTERNDECL); globs = varlist(strom,&delim); pstat(PCLEAR,EXTERNDECL); if(globs == parserrsym) goto cleanup1; globs = varssyms(globs); } else { globs = voidsym; } WORKpush(globs); if(markglobs(globs) == aERROR) goto cleanup2; /********** declaration of constants *********/ if(delim == constsym) { pstat(PSET,CONSTDECL); consts = lconstlist(strom,&delim); if(consts == parserrsym) goto cleanup2; pstat(PCLEAR,CONSTDECL); WORKpush(varssyms(consts)); if(Lconstini(consts) == aERROR) goto cleanup3; } else { WORKpush(voidsym); } /******** declaration of local variables ********/ if(delim == varsym) { vars = varlist(strom,&delim); if(vars == parserrsym) goto cleanup3; } else { vars = voidsym; } if(delim != beginsym) { errexpect(funcsym,beginsym,delim); goto cleanup3; } vars2push(vars); numvars = marksymbs(*workStkPtr); if(numvars == aERROR) goto cleanup4; /******** function body *********/ nexttok(strom,1); numstats = statements(strom,&delim); if(numstats == aERROR || delim != endsym) { errflg = 1; } else if(curtok(strom) == SYMBOLTOK) { sflg = lookupsym(SymBuf,&delim); if(sflg != aERROR && delim == fun) nexttok(strom,0); else errflg = 1; } if(errflg) { rerror(funcsym,err_synt,voidsym); goto cleanup4; } body = mkcompnode(fCOMPEXPR,numstats); PARSnpop(numstats); PARSpush(body); sptr = symptr(fun); *FLAGPTR(sptr) = (vflg ? sVFUNCTION : sFUNCTION); sptr->bind.t = mkfundef(numparms,numopts,numvars); obj = fun; cleanup4: vars = worksav[4]; unmarksymbs(vars); cleanup3: consts = worksav[3]; unmarksymbs(consts); Lconstini(voidsym); cleanup2: globs = worksav[2]; unmarksymbs(globs); cleanup1: parms = worksav[1]; unmarksymbs(parms); locsymbs = 0; argStkPtr = parssav; workStkPtr = worksav; ausgang: pstat(PCLEAR,COMPILING); return(obj); } /*--------------------------------------------------------------*/ /* ** symbs ist ein bnode, wie er von varlist geliefert wird. ** Das erste Argument (Symbolliste) wird zurueckgegeben */ PRIVATE truc varssyms(symbs) truc symbs; { if(symbs == voidsym) return(symbs); else return(NODEarg0(symbs)); } /*--------------------------------------------------------------*/ /* ** symbs ist ein bnode, wie er von varlist geliefert wird. ** Das erste Argument (Symbolliste) wird auf den WorkStack gelegt, ** das zweite (Liste der Initialisierungen) auf den ParsStack */ PRIVATE void vars2push(symbs) truc symbs; { truc *ptr; if(symbs == voidsym) { WORKpush(symbs); PARSpush(symbs); } else { ptr = Taddress(symbs); WORKpush(ptr[1]); PARSpush(ptr[2]); } } /*--------------------------------------------------------------*/ PRIVATE truc getfuname(strom) truc *strom; { truc fun; int tok, sflg; tok = nexttok(strom,1); if(tok != SYMBOLTOK) { rerror(funcsym,err_sym,voidsym); return(parserrsym); } fun = mksym(SymBuf,&sflg); if(sflg >= sSYSTEM) { rerror(funcsym,err_funame,fun); return(parserrsym); } return(fun); } /*--------------------------------------------------------------*/ /* ** Die formalen Parameter einer Funktion (Liste symbs) werden mit ** fortlaufenden Nummern markiert. Aus der Liste kind ist ** abzulesen, ob es sich um einen Variablen-Parameter handelt. ** In diesem Fall wird die Nummer um mGLOBAL erhoeht */ PRIVATE int markparms(symbs,kind) truc symbs, kind; { truc *ptr, *ptr1; word2 *p0; int i, n; if(symbs == voidsym) return(0); ptr = Taddress(symbs); n = *WORD2PTR(ptr); ptr1 = Taddress(kind); for(i=1; i<=n; i++) { p0 = SYMCC0PTR(ptr+i); if(*p0) { rerror(funcsym,err_2ident,ptr[i]); return(aERROR); } *p0 = ++locsymbs; if(*FLAGPTR(ptr1 + i) == fSPECIAL1) { /* dann Variable-Parameter */ *p0 |= mGLOBAL; } } return(n); } /*--------------------------------------------------------------*/ /* ** In einer Funktion vorkommende lokale Variable werden mit ** fortlaufenden Nummern markiert ** Die letzte benutzte Nummer steht in der globalen Variablen locsymbs */ PRIVATE int marksymbs(symbs) truc symbs; { truc *ptr; word2 *p0; int i, n; if(symbs == voidsym) return(0); ptr = Taddress(symbs); n = *WORD2PTR(ptr); for(i=1; i<=n; i++) { p0 = SYMCC0PTR(ptr+i); if(*p0) { rerror(funcsym,err_2ident,ptr[i]); return(aERROR); } *p0 = ++locsymbs; } return(n); } /*--------------------------------------------------------------*/ /* ** In einer Funktion vorkommende globale Variable werden in der ** Symbol-Tabelle mit der Marke mGLOBAL markiert. */ PRIVATE int markglobs(symbs) truc symbs; { truc *ptr; word2 *p0; int i, n; if(symbs == voidsym) return(0); ptr = Taddress(symbs); n = *WORD2PTR(ptr); for(i=1; i<=n; i++) { p0 = SYMCC0PTR(ptr+i); if(*p0) { rerror(funcsym,err_2ident,ptr[i]); return(aERROR); } *p0 = mGLOBAL; } return(n); } /*--------------------------------------------------------------*/ /* ** Markierung von Symbolen waehrend der Compilation wird wieder geloescht */ PRIVATE void unmarksymbs(symbs) truc symbs; { truc *ptr; int i, n; if(symbs == voidsym) return; ptr = Taddress(symbs); n = *WORD2PTR(ptr); for(i=1; i<=n; i++) { *SYMCC0PTR(ptr+i) = 0; } } /*--------------------------------------------------------------*/ /* ** falls waehrend der Compilation ein Reset vorkommt, ** muessen alle Markierungen mit clearcompile geloescht werden */ PUBLIC void clearcompile() { truc *ptr; int i; if(pstat(PQUERY,COMPILING)) { i = 0; while((ptr = nextsymptr(i++)) != NULL) *SYMCC0PTR(ptr) = 0; } locsymbs = 0; pstat(PCLEARALL,0); } /*--------------------------------------------------------------*/ /* ** Liest die formale Parameterliste einer Funktions-Definition ** einschliesslich der Klammern '(' und ')' . */ PRIVATE truc parmlist(strom,vflgptr,optcptr) truc *strom; int *vflgptr, *optcptr; { truc *parssav, *worksav; truc obj, delim; int varflg, optc; int tok; int k = 0, n = 0; tok = nexttok(strom,1); if(tok != LPARENTOK) { rerror(funcsym,err_0lparen,voidsym); return(parserrsym); } parssav = argStkPtr; worksav = workStkPtr; *vflgptr = 0; tok = nexttok(strom,1); /* ueberlese LPARENTOK */ if(tok == RPARENTOK) { nexttok(strom,0); /* ueberlese RPARENTOK */ k = -1; } optc = 0; while(k >= 0) { k = parmsection(strom,&delim,&varflg); if(optc && varflg != -1) { k = aERROR; } else if(varflg == -1) optc += k; else if(varflg == 1) *vflgptr = 1; if(k >= 0) { n += k; if(delim == nullsym) { /* denotes RPARENTOK */ nexttok(strom,0); break; } } else if(k == aERROR) { rerror(funcsym,err_parl,voidsym); obj = parserrsym; goto cleanup; } } obj = mkntuple(fTUPLE,parssav+1,n); PARSpush(obj); obj = mkntuple(fTUPLE,worksav+1,n); PARSpush(obj); obj = mkbnode(inivarsym); cleanup: *optcptr = optc; argStkPtr = parssav; workStkPtr = worksav; return(obj); } /*--------------------------------------------------------------*/ PRIVATE truc varlist(strom,endptr) truc *strom; truc *endptr; { truc *parssav, *worksav; truc obj; int k, n; nexttok(strom,1); /* ueberspringe var oder record */ parssav = argStkPtr; worksav = workStkPtr; n = 0; while(1) { k = varsection(strom,endptr); if(k >= 0) { n += k; } else if(k == aERROR) { obj = parserrsym; goto cleanup; } else break; } obj = mkntuple(fTUPLE,parssav+1,n); PARSpush(obj); obj = mkntuple(fTUPLE,worksav+1,n); PARSpush(obj); obj = mkbnode(inivarsym); cleanup: argStkPtr = parssav; workStkPtr = worksav; return(obj); } /*--------------------------------------------------------------*/ /* ** Parst eine lokale Konstantendeklaration. ** Die benutzten Konstantennamen werden markiert. ** Zurueckgegeben wird ein bnode mit zwei n-tuplen aus ** Konstantennamen und Liste der Initialisierungen. ** Ist die Konstantendeklaration leer, wird voidsym zurueckgegeben. ** Im Fehlerfall wird parserrsym zurueckgegeben und die ** Markierungen werden wieder geloescht. */ PRIVATE truc lconstlist(strom,endptr) truc *strom; truc *endptr; { truc *parssav, *worksav; truc obj; word2 *pt2; int tok, sflg; int n; parssav = argStkPtr; worksav = workStkPtr; tok = nexttok(strom,1); /* ueberspringe const */ n = 0; while(1) { if(tok != SYMBOLTOK) { rerror(constsym,err_sym,voidsym); goto unmarkcleanup; } obj = mksym(SymBuf,&sflg); if(sflg >= sSYSTEM) { *endptr = obj; break; } PARSpush(obj); tok = nexttok(strom,1); if(tok != EQTOK) { errexpect(constsym,equalsym,voidsym); goto unmarkcleanup; } tok = nexttok(strom,0); obj = readexpr(strom,0); if(obj == parserrsym) { goto unmarkcleanup; } WORKpush(obj); /** mark local constant **/ pt2 = SYMCC0PTR(argStkPtr); if(*pt2) { rerror(constsym,err_2ident,*argStkPtr); goto unmarkcleanup; } else { *pt2 = mLOCCONST + n; n++; } tok = skipeoltok(strom); if(tok == SEMICOLTOK) tok = nexttok(strom,1); } if(n > 0) { obj = mkntuple(fTUPLE,parssav+1,n); PARSpush(obj); obj = mkntuple(fTUPLE,worksav+1,n); PARSpush(obj); obj = mkbnode(inivarsym); } else obj = voidsym; goto cleanup; unmarkcleanup: obj = mkntuple(fTUPLE,parssav+1,n); unmarksymbs(obj); obj = parserrsym; cleanup: argStkPtr = parssav; workStkPtr = worksav; return(obj); } /*--------------------------------------------------------------*/ /* ** Liest eine Zeile ein Variablen-Deklaration der Gestalt ** Sym1, ..., Symk: Type; ** bzw. ** Sym1, ..., Symk; ** und legt die Symbole auf den ParsStack; gleichzeitig ** werden die Initialisierungen auf den WorkStack gelegt. ** Die Stacks werden nicht aufgeraeumt!! ** Rueckgabewert: ** Anzahl der Symbole, falls erfolgreich ** -1, falls Liste zu Ende. ** In diesem Fall wird das Endsymbol in *endptr abgelegt. ** aERROR, falls Fehler */ PRIVATE int varsection(strom,endptr) truc *strom; truc *endptr; { truc typ; int tok; int i, n; tok = skipeoltok(strom); n = varsaux(tok,strom,&typ,endptr); if(n == aERROR) { /* Fehlermeldung nicht immer zutreffend, da auch von ** globtypedef aus benutzt */ rerror(varsym,err_varl,voidsym); } else for(i=0; i= sSYSTEM) { if(n == 0) { *endptr = obj; n = -1; } else n = aERROR; break; } PARSpush(obj); n++; tok = nexttok(strom,1); if(tok == COMMATOK) { tok = nexttok(strom,1); continue; } else if(tok == COLONTOK) { *typptr = typespec(strom); if(*typptr == parserrsym) { n = aERROR; break; } tok = skipeoltok(strom); } else if(tok == ASSIGNTOK) { nexttok(strom,0); if(n != 1) { n = aERROR; break; } *typptr = readexpr(strom,0); if(*typptr == parserrsym) { n = aERROR; break; } *ofptr = 1; tok = skipeoltok(strom); } if(tok == SEMICOLTOK) { tok = nexttok(strom,1); } else if(tok == SYMBOLTOK) { if(lookupsym(SymBuf,endptr) != sDELIM) n = aERROR; } else if(tok != RPARENTOK) n = aERROR; break; } if(tok == RPARENTOK) { *endptr = nullsym; } return(n); } /*--------------------------------------------------------------*/ PRIVATE int varsaux(tok,strom,typptr,endptr) int tok; truc *strom; truc *typptr, *endptr; { truc obj; int sflg; int n = 0; *typptr = zero; /* default type integer */ *endptr = voidsym; if(tok != SYMBOLTOK) { return(aERROR); } while(tok == SYMBOLTOK) { obj = mksym(SymBuf,&sflg); if(sflg >= sSYSTEM) { if(n == 0) { *endptr = obj; n = -1; } else n = aERROR; break; } PARSpush(obj); n++; tok = nexttok(strom,1); if(tok == COMMATOK) { tok = nexttok(strom,1); continue; } else if(tok == COLONTOK) { *typptr = typespec(strom); if(*typptr == parserrsym) { n = aERROR; break; } tok = skipeoltok(strom); } else if(tok == ASSIGNTOK) { nexttok(strom,0); if(n != 1) { n = aERROR; break; } obj = readexpr(strom,0); *typptr = obj; tok = skipeoltok(strom); } if(tok == SEMICOLTOK) { tok = nexttok(strom,1); } else if(tok == SYMBOLTOK) { if(lookupsym(SymBuf,endptr) != sDELIM) n = aERROR; } else n = aERROR; break; } return(n); } /*--------------------------------------------------------------*/ /* ** Liest eine Typ-Spezifikation und liefert als Ergebnis ** den Default-Anfangswert dieses Typs bzw. einen ** Funktions-Aufruf, der diesen Anfangswert erzeugt ** Im Fehlerfall wird parserrsym zurueckgegeben. */ PRIVATE truc typespec(strom) truc *strom; { truc typ, obj, sym; int tok, sflg, mode; int n; int weiter = 1; obj = parserrsym; tok = nexttok(strom,1); /* ueberlese : oder = */ if(tok != SYMBOLTOK) return(parserrsym); typ = mksym(SymBuf,&sflg); if(sflg == sTYPESPEC) { if(typ == integsym || typ == boolsym || typ == charsym || typ == gf2nintsym) { obj = SYMbind(typ); } else if(typ == realsym) { obj = fltzero(deffltprec()); } else if(typ == stringsym || typ == bstringsym) { tok = nexttok(strom,1); if(tok == LBRACKTOK) { obj = readbrack(strom,&mode); if(obj == parserrsym || mode == 1) return(parserrsym); PARSpush(obj); sym = (typ == stringsym ? mkstrsym : mkbstrsym); obj = mkunode(sym); /* fBUILTIN1 */ PARSpop(); } else { obj = (typ == stringsym ? nullstring : nullbstring); } weiter = 0; } else if(typ == arraysym) { tok = nexttok(strom,1); if(tok == LBRACKTOK) { obj = readbrack(strom,&mode); if(obj == parserrsym || mode == 1) return(parserrsym); } else obj = zero; PARSpush(obj); n = 1; tok = skipeoltok(strom); if(tok == SYMBOLTOK) { sflg = lookupsym(SymBuf,&obj); if(obj == ofsym) { obj = typespec(strom); PARSpush(obj); n = 2; } } if(obj != parserrsym) obj = mkfunode(mkarrsym,n); /* fBUILTINn */ PARSnpop(n); weiter = 0; } else if(typ == recordsym) { obj = readrecdef(strom); weiter = 0; PARSpush(obj); if(obj != parserrsym) obj = mkunode(mkrecsym); /* fBUILTIN1 */ PARSpop(); } else if(typ == pointrsym) { obj = pointertype(strom); weiter = 0; PARSpush(obj); PARSpush(nil); if(obj != parserrsym) obj = mkrecord(fPOINTER,argStkPtr-1,2); PARSnpop(2); } else if(typ == filesym || typ == stacksym || typ == symbsym) { obj = SYMbind(typ); } } else if(sflg == sTYPEDEF) { /* user defined type */ obj = SYMbind(typ); } else if(sflg == sPARSAUX) { if(typ == funcsym || typ == procsym || (pstat(PQUERY,EXTERNDECL) && typ == constsym)) obj = typ; } if(weiter) nexttok(strom,1); return(obj); } /*--------------------------------------------------------------*/ PRIVATE truc globtypedef(strom) truc *strom; { truc *worksav, *ptr; truc delim; truc sym, obj; int i, n, tok, sflg; int errflg; if(pstat(PQUERY,COMPILING)) { rerror(typesym,err_synt,voidsym); return(parserrsym); } tok = nexttok(strom,1); /* ueberspringe type */ delim = voidsym; worksav = workStkPtr; n = 0; errflg = 1; pstat(PSET,POINTRECURS); while(tok == SYMBOLTOK) { sym = mksym(SymBuf,&sflg); if(sflg >= sSYSTEM) { delim = sym; if(n > 0) errflg = 0; break; } tok = nexttok(strom,1); if(tok != EQTOK) { errexpect(typesym,equalsym,voidsym); break; } WORKpush(sym); n++; obj = typespec(strom); if(obj == parserrsym) { rerror(typesym,err_btype,voidsym); break; } *SYMFLAGPTR(workStkPtr) = sTYPEDEF; *SYMBINDPTR(workStkPtr) = obj; tok = nexttok(strom,1); if(tok == SEMICOLTOK) tok = nexttok(strom,1); } pstat(PCLEAR,POINTRECURS); if(decldelim(delim) == 0) { errexpect(typesym,endsym,delim); errflg = 1; } else if(delim == endsym) nexttok(strom,0); if(!errflg) { obj = typesym; /******* fix recursive pointer types ********/ for(i=1; i<=n; i++) { sym = *SYMBINDPTR(worksav+i); if(Tflag(sym) == fPOINTER) { ptr = Taddress(sym); if(*FLAGPTR(ptr+1) == fTUPLE) { /* nothing to do */ continue; } sym = ptrtypeval(ptr[1]); if(sym == parserrsym) { errflg = 1; break; } else { ptr[1] = sym; } } } /* end for */ } if(errflg) { while(--n >= 0) { unbindsym(workStkPtr); WORKpop(); } obj = parserrsym; } workStkPtr = worksav; return(obj); } /*--------------------------------------------------------------*/ PRIVATE truc globconstdef(strom) truc *strom; { truc *worksav; truc sym, obj, delim; int tok, sflg, errflg; int n; if(pstat(PQUERY,COMPILING)) { rerror(constsym,err_synt,voidsym); return(parserrsym); } worksav = workStkPtr; delim = voidsym; n = 0; errflg = 1; tok = nexttok(strom,1); /* ueberspringe const */ while(tok == SYMBOLTOK) { sym = mksym(SymBuf,&sflg); if(sflg >= sSYSTEM) { delim = sym; if(n > 0) errflg = 0; break; } tok = nexttok(strom,1); if(tok != EQTOK) { errexpect(constsym,equalsym,voidsym); errflg = 1; break; } WORKpush(sym); n++; tok = nexttok(strom,0); obj = readexpr(strom,0); if(obj == parserrsym || (obj = eval(&obj)) == breaksym) { errflg = 1; break; } *SYMFLAGPTR(workStkPtr) = sCONSTANT; *SYMBINDPTR(workStkPtr) = obj; tok = skipeoltok(strom); if(tok == SEMICOLTOK) tok = nexttok(strom,1); } if(!decldelim(delim)) { errexpect(constsym,endsym,delim); errflg = 1; } if(delim == endsym) nexttok(strom,0); if(errflg) { while(--n >= 0) { unbindsym(workStkPtr); WORKpop(); } obj = parserrsym; } else obj = constsym; workStkPtr = worksav; return(obj); } /*--------------------------------------------------------------*/ PRIVATE truc globvardef(strom) truc *strom; { truc obj, delim; if(pstat(PQUERY,COMPILING)) { rerror(varsym,err_synt,voidsym); return(parserrsym); } obj = varlist(strom,&delim); if(!decldelim(delim)) { errexpect(varsym,endsym,delim); return(parserrsym); } else if(delim == endsym) { nexttok(strom,0); } return(obj); } /*--------------------------------------------------------------*/ PRIVATE int decldelim(delim) truc delim; { if(delim == endsym) return 1; else if(delim == varsym) return 2; else if(delim == constsym) return 3; else if(delim == typesym) return 4; else if(delim == procsym) return 5; else if(delim == funcsym) return 6; else return 0; } /*--------------------------------------------------------------*/ /* ** Klammer-Ausdruck, ** Argumentliste fuer Funktionsaufruf, ** oder Komponenten eines Vektors. ** Liest eine Folge von Expressions, die durch Kommas ** getrennt sind und die durch endtok (RPARENTOK oder RBRACETOK) ** beendet wird. ** Die Expressions werden auf den PARSstack gelegt. ** Rueckgabewert ist bei Erfolg die Anzahl der Expressions, ** der PARSstack wird nicht aufgeraeumt!! ** Falls ein Fehler auftritt wird aERROR zurueckgegeben und der ** PARSstack wird aufgeraeumt */ PRIVATE int arglist(strom,endtok) truc *strom; int endtok; { truc obj; int tok, ret; int fehler = 0; int n = 0; char *errmess; tok = nexttok(strom,1); /* ueberlese linke Klammer */ pstat(PSET,ARGLIST); while(tok != endtok) { obj = readexpr(strom,0); if(obj == parserrsym) { fehler = 1; break; } else { PARSpush(obj); n++; } tok = skipeoltok(strom); if(tok == COMMATOK) nexttok(strom,1); else if(tok != endtok) { errmess = (endtok == RBRACETOK ? err_0brace : err_0rparen); rerror(parserrsym,errmess,voidsym); fehler = 1; break; } } pstat(PCLEAR,ARGLIST); if(fehler) { PARSnpop(n); ret = aERROR; } else { nexttok(strom,0); ret = n; } return(ret); } /*--------------------------------------------------------------*/ /* ** Liefert ein fTUPLE der Laenge 2*n, das einen Record beschreibt ** oder ein Symbol, das moeglicherweise Typ-Bezeichnung ** eines Records ist. ** Im Fehlerfall wird parserrsym zurueckgegeben. */ PRIVATE truc pointertype(strom) truc *strom; { truc obj, typ; int sflg; nexttok(strom,0); sflg = obligsym(pointrsym,strom,tosym); if(sflg == aERROR || skipeoltok(strom) != SYMBOLTOK) return(parserrsym); typ = mksym(SymBuf,&sflg); if(typ == recordsym) { obj = readrecdef(strom); } else { /* typ must be a symbol designing a record type */ if(!pstat(PQUERY,POINTRECURS)) { /* get record type (fTUPLE) given by typ */ obj = ptrtypeval(typ); } else { /* to be fixed later */ obj = typ; } nexttok(strom,1); } return(obj); } /*--------------------------------------------------------------*/ /* ** typ ist ein Symbol, das fuer einen record-Typ steht. ** Funktion liefert ein 2*n-tupel aus n Feldbezeichnungen und n ** Anfangswerten bzw. Anfangswert-Prozeduren fuer den Record, ** auf den der Pointer zeigen soll. ** Im Fehlerfall wird parserrsym zurueckgegeben. */ PRIVATE truc ptrtypeval(typ) truc typ; { struct symbol *sptr; truc *ptr; truc obj; int flg; int depth = 0; nochmal: if(++depth > 64) { error(typesym,err_rec,mkfixnum(depth)); goto errexit; } sptr = symptr(typ); if(*FLAGPTR(sptr) != sTYPEDEF) goto errexit; typ = sptr->bind.t; flg = Tflag(typ); if(flg == fSYMBOL) goto nochmal; else if(flg == fBUILTIN1) { ptr = Taddress(typ); if(ptr[0] != mkrecsym) goto errexit; obj = ptr[1]; flg = Tflag(obj); if(flg == fSYMBOL) { typ = obj; goto nochmal; } else if(flg == fTUPLE) return(obj); } errexit: return(parserrsym); } /*--------------------------------------------------------------*/ /* ** Liest eine record-Definition und liefert ein 2*n-tupel ** aus den n Feldbezeichnern und den n Anfangsdaten ** Im Fehlerfall wird parserrsym zurueckgegeben. */ PRIVATE truc readrecdef(strom) truc *strom; { truc *worksav; truc *ptr, *ptr1, *ptr2; truc delim, obj; int i,n; obj = varlist(strom,&delim); if(obj == parserrsym) return(parserrsym); if(delim != endsym) { errexpect(recordsym,endsym,delim); return(parserrsym); } else nexttok(strom,1); worksav = workStkPtr; if(obj == voidsym) n = 0; else { ptr = Taddress(obj); ptr1 = Taddress(ptr[1]); /* symbols */ ptr2 = Taddress(ptr[2]); /* initial values */ n = *WORD2PTR(ptr1); if(WORKspace(2*n) == NULL) reset(err_wrkstk); for(i=1; i<=n; i++) { worksav[i] = ptr1[i]; worksav[n+i] = ptr2[i]; } } obj = mkntuple(fTUPLE,worksav+1,2*n); workStkPtr = worksav; return(obj); } /*--------------------------------------------------------------*/ PRIVATE truc readwhile(strom) truc *strom; { truc *savptr; truc obj, delim; int m, n = 0; int sflg; savptr = argStkPtr; nexttok(strom,0); /* ueberspringe while */ obj = readexpr(strom,0); if(obj == parserrsym) { goto cleanup; } PARSpush(obj); n++; sflg = obligsym(whilesym,strom,dosym); if(sflg == aERROR) { obj = parserrsym; goto cleanup; } m = statements(strom,&delim); if(m == aERROR || delim != endsym) { errexpect(whilesym,endsym,voidsym); obj = parserrsym; goto cleanup; } n += m; obj = mkntuple(fWHILEXPR,argStkPtr-n+1,n); cleanup: argStkPtr = savptr; return(obj); } /*--------------------------------------------------------------*/ PRIVATE truc readfor(strom) truc *strom; { truc *savptr; truc obj, delim, inc; int m, n = 0; int tok, sflg; savptr = argStkPtr; tok = nexttok(strom,1); /* ueberspringe for */ if(tok != SYMBOLTOK || (sflg=parsedsym(SymBuf,&obj)) == aERROR || sflg > sVARIABLE) { /* obj ist Lauf-Variable */ /* genauere Fehlermeldung wuenschenswert */ rerror(forsym,err_sym,voidsym); return(parserrsym); } PARSpush(obj); n++; tok = nexttok(strom,1); if(tok != ASSIGNTOK) { rerror(forsym,err_synt,voidsym); obj = parserrsym; goto cleanup; } nexttok(strom,1); obj = readexpr(strom,0); /* Start-Wert */ PARSpush(obj); n++; sflg = obligsym(forsym,strom,tosym); if(sflg == aERROR) { obj = parserrsym; goto cleanup; } obj = readexpr(strom,0); /* End-Wert */ PARSpush(obj); n++; tok = skipeoltok(strom); if(tok == SYMBOLTOK) { delim = mksym(SymBuf,&sflg); if(delim == dosym) { nexttok(strom,1); inc = constone; } else if(delim == bysym) { nexttok(strom,1); inc = readexpr(strom,0); sflg = obligsym(forsym,strom,dosym); if(sflg == aERROR) { obj = parserrsym; goto cleanup; } } else sflg = aERROR; } else sflg = aERROR; if(sflg == aERROR) { errexpect(forsym,dosym,voidsym); obj = parserrsym; goto cleanup; } PARSpush(inc); n++; m = statements(strom,&delim); if(m == aERROR || delim != endsym) { errexpect(forsym,endsym,voidsym); obj = parserrsym; goto cleanup; } n += m; obj = mkntuple(fFOREXPR,argStkPtr-n+1,n); cleanup: argStkPtr = savptr; return(obj); } /*--------------------------------------------------------------*/ /* ** Stellt fest, ob das zuletzt aus strom gelesene Objekt ** das Symbol symb war und gibt ggf. Fehlermeldung aus. ** Es wird weitergelesen */ PRIVATE int obligsym(fun,strom,symb) truc fun; truc *strom; truc symb; { truc obj; int tok, ret; int sflg; tok = skipeoltok(strom); if(tok != SYMBOLTOK) { /* genauere Fehlerbehandlung wuenschenswert */ ret = aERROR; } else { sflg = lookupsym(SymBuf,&obj); ret = (obj == symb ? sflg : aERROR); } if(ret == aERROR) { errexpect(fun,symb,voidsym); } nexttok(strom,0); return(ret); } /*--------------------------------------------------------------*/ PRIVATE void errexpect(fun,symb,esym) truc fun, symb, esym; { char buf[80]; strcopy(buf + strcopy(buf,SYMname(symb))," expected"); rerror(fun,buf,esym); } /*--------------------------------------------------------------*/ /* ** Liest eine Folge von Expressions, die durch Semicolons ** getrennt sind und durch ein Trenn-Symbol beendet wird, ** das in *endptr abgelegt wird. ** Die Expressions werden auf den PARSstack gelegt. ** Rueckgabewert ist bei Erfolg die Anzahl der Expressions, ** der PARSstack wird nicht aufgeraeumt. ** Falls ein Fehler auftritt, wird aERROR zurueckgegeben und der ** PARSstack aufgeraeumt */ PRIVATE int statements(strom,endptr) truc *strom; truc *endptr; { truc obj; int tok; int n = 0; while(1) { tok = skipeoltok(strom); if(tok == SEMICOLTOK) { nexttok(strom,1); continue; } else if(tok == SYMBOLTOK) { if(lookupsym(SymBuf,endptr) == sDELIM) { nexttok(strom,0); break; } } obj = readexpr(strom,0); if(obj == parserrsym || obj == breaksym) { PARSnpop(n); return(aERROR); } else if(obj == enddotsym) { break; } else { PARSpush(obj); n++; } } return(n); } /*--------------------------------------------------------------*/ PRIVATE truc readif(strom) truc *strom; { truc *savptr; truc obj, delim; int sflg; int m, n = 0; savptr = argStkPtr; nexttok(strom,0); /* ueberspringe if */ while(1) { obj = readexpr(strom,0); if(obj == parserrsym) { goto cleanup; } PARSpush(obj); n++; sflg = obligsym(ifsym,strom,thensym); if(sflg == aERROR) { obj = parserrsym; goto cleanup; } m = statements(strom,&delim); if(m == aERROR) { errexpect(ifsym,endsym,voidsym); obj = parserrsym; goto cleanup; } obj = mkcompnode(fCOMPEXPR,m); PARSnpop(m); PARSpush(obj); n++; if(delim != elsifsym) break; } if(delim == elsesym) { m = statements(strom,&delim); if(m == aERROR || delim != endsym) { errexpect(ifsym,endsym,voidsym); obj = parserrsym; goto cleanup; } obj = mkcompnode(fCOMPEXPR,m); PARSnpop(m); PARSpush(obj); n++; } else if(delim == endsym) { PARSpush(voidsym); n++; } else { rerror(ifsym,err_synt,delim); obj = parserrsym; goto cleanup; } obj = mkntuple(fIFEXPR,argStkPtr-n+1,n); cleanup: argStkPtr = savptr; return(obj); } /*--------------------------------------------------------------*/ PRIVATE truc negate(obj) truc obj; { PARSpush(zero); PARSpush(obj); obj = optbnode(uminsym); PARSnpop(2); return(obj); } /*--------------------------------------------------------------*/ PRIVATE void recoverr(strom) truc *strom; { int tok; /* vorlaeufig */ tok = curtok(strom); while(tok != EOLTOK && tok != EOFTOK) tok = nexttok(strom,0); if(*strom == tstdin) dumpinput(); } /*--------------------------------------------------------------*/ PRIVATE truc tmptoksym(tok) int tok; { char *name; switch(tok) { case EOFTOK: name = "end of input"; break; case EOLTOK: name = "end-of-line token"; break; case LPARENTOK: name = "left parenthesis ("; break; case RPARENTOK: name = "right parentesis )"; break; case LBRACKTOK: name = "left bracket ["; break; case RBRACKTOK: name = "right bracket ]"; break; case LBRACETOK: name = "left brace {"; break; case RBRACETOK: name = "right brace }"; break; case BEGCOMMTOK: name = "begin comment token"; break; case ENDCOMMTOK: name = "end comment token"; break; case COMMATOK: name = "comma token"; break; case COLONTOK: name = "colon token ':'"; break; case SEMICOLTOK: name = "semi colon token"; break; case DOTTOK: name = "dot token"; break; case DOTDOTTOK: name = "dot dot token '..'"; break; case RECDOTTOK: name = "record field separator"; break; case DEREFTOK: name = "dereferencing token '^'"; break; case DOLLARTOK: name = "dollar token"; break; case HISTORYTOK: name = "history token '!'"; break; case QUESTIONTOK: name = "question mark"; break; case ASSIGNTOK: name = "assignment token :="; break; case ORTOK: name = "or token"; break; case ANDTOK: name = "and token"; break; case NOTTOK: name = "not token"; break; case EQTOK: name = "equal token"; break; case NETOK: name = "not equal token"; break; case LTTOK: name = "less than token"; break; case LETOK: name = "token <="; break; case GTTOK: name = "greater than token"; break; case GETOK: name = "token >="; break; case PLUSTOK: name = "plus token"; break; case MINUSTOK: name = "minus token"; break; case TIMESTOK: name = "times token '*'"; break; case DIVIDETOK: name = "divide token '/'"; break; case DIVTOK: name = "div token"; break; case MODTOK: name = "mod token"; break; case UMINUSTOK: name = "unitary minus token"; break; case POWERTOK: name = "power token **"; break; case BOOLTOK: name = "boolean value"; break; case CHARTOK: name = "character token"; break; case INUMTOK: name = "integer"; break; case GF2NTOK: name = "gf2nint"; break; case FLOATTOK: name = "floating point number"; break; case STRINGTOK: name = "string token"; break; case BSTRINGTOK: name = "byte_string token"; break; case SYMBOLTOK: name = "symbol"; break; case VECTORTOK: name = "array"; break; default: name = "unidentified token"; } return(scratch(name)); } /********************************************************************/ aribas165b/src/print.c0000644000076600000240000013333514660570651013677 0ustar ottostaff/****************************************************************/ /* file print.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** print.c ** functions for output formatting ** ** date of last change ** 1995-01-03: integer return for write and writeln ** 1995-01-26: NEEDFLUSH ** 1995-03-11: changed s1form, s2form ** 1995-03-28: fRECORD, fPOINTER ** 1995-04-08: ASCII 0 in strings ** 1995-07-16: fixed bug in left alignment of strings ** 1996-08-04: fixed bug in base 8 formatting ** 1996-11-03: renamed protocol() to transcript() ** 1997-04-13: reorg (newintsym) ** 1997-07-05: changed setcols (no special role of tstdout) ** error return value of write() and writeln() set to -1 ** 1997-12-20: small change in fprintline ** 1998-10-01: adjustments for Win32GUI ** 2001-01-01: multiprec floats ** 2001-03-30: Win32GUI replaces genWinGUI ** 2001-06-02: function flushlog ** 2002-04-01: allow interrupt while printing vectors ** 2002-08-03: baseprefix changed, ** changed argument type of s1form, s2form, sformaux ** 2003-02-21: Gformat also for gf2nint's ** 2010-02-06: s1form, s2form ** 2010-02-20: fflush in log2out(), NEEDFLUSH deleted */ #include "common.h" PUBLIC void iniprint (int cols); PUBLIC int logout (int ch); PUBLIC void strlogout (char *str); PUBLIC void closelog (void); PUBLIC void flushlog (void); PUBLIC void tprint (truc strom, truc obj); PUBLIC int strcopy (char *tostr, char *fromstr); PUBLIC int strncopy (char *tostr, char *fromstr, int maxlen); PUBLIC int fprintstr (truc strom, char *str); PUBLIC void fprintline (truc strom, char *str); PUBLIC void fnewline (truc strom); PUBLIC void ffreshline (truc strom); PUBLIC void flinepos0 (truc strom); PUBLIC wtruc strcast (char *str); PUBLIC wtruc intcast (long int); PUBLIC int s1form (char *buf, char *fmt, wtruc dat); PUBLIC int s2form (char *buf, char *fmt, wtruc dat1, wtruc dat2); PUBLIC int setprnprec (int prec); PUBLIC truc writesym, writlnsym, formatsym; PUBLIC truc transcsym; PUBLIC char OutBuf[IOBUFSIZE+4]; PUBLIC int Log_on = 0; /*----------------------------------------------------*/ #define FORMPARAM 5 #define NOTSET -32768 #define DEFAULT 0 typedef struct { int mode; int param[FORMPARAM]; } forminfo; PRIVATE ifun putcfun (truc strom); PRIVATE int charout (int ch); PRIVATE int charoutf (int ch); PRIVATE int log2out (int ch); PRIVATE truc Ftranscript (int argn); PRIVATE truc F1write (int argn); PRIVATE truc Fwritln (int argn); PRIVATE truc Fint2str (int argn); PRIVATE truc Fflt2str (void); PRIVATE truc Secvt (void); PRIVATE truc Gformat (void); PRIVATE int Gprint (int argn, int nl); PRIVATE int setcols (truc strom, truc *ptr); PRIVATE void getform (forminfo *fptr, truc obj, truc *arr, int n); PRIVATE truc Fsetpbase (void); PRIVATE truc Fgetpbase (void); PRIVATE int admissbase (int base); PRIVATE int printbase (int base); PRIVATE char *baseprefix (int base, int mode); PRIVATE int nibasci0 (word2 *x, int k); PRIVATE void printfint (truc strom, truc obj, forminfo *fptr); PRIVATE void printfloat (truc strom, truc obj, forminfo *fptr); PRIVATE int printvector (truc strom, truc obj); PRIVATE int printrecord (truc strom, truc obj); PRIVATE int printvvrr (truc strom, truc obj, int flg); PRIVATE void printstring (truc strom, truc obj, forminfo *fptr); PRIVATE void printbstring (truc strom, truc obj, forminfo *fptr); PRIVATE int bytes2hex (char *str, byte *buf, int len); PRIVATE int sym2str (truc obj, char *buf); PRIVATE int float2str (truc obj, char *buf, forminfo *fptr, word2 *hilf); PRIVATE int fixstring (numdata *nptr, int dec, char *buf); PRIVATE int char2str (truc obj, char *buf, forminfo *fptr); PRIVATE int bool2str (truc obj, char *buf); PRIVATE word4 truc2msf (truc obj); PRIVATE int ptr2str (truc obj, char *buf); PRIVATE int obj2str (int flg, truc obj, char *buf); PRIVATE int leftpad (char *buf, int width, int ch); PRIVATE int fillspaces (char *buf, int n); PRIVATE void strnfcopy (char *tostr, char *fromstr, unsigned len); PRIVATE int fprintwrap (truc strom, char *str, int bound, int contmark); PRIVATE int fprintmarg (truc strom, char *str, int len); PRIVATE int fprintch (truc strom, int ch); PRIVATE int long2alfa (char *buf, long u); PRIVATE int long2s0alfa (char *buf, long u, int len); PRIVATE int word4xalfa (char *buf, word4 u); PRIVATE int sformaux (forminfo *fmptr, char *buf, wtruc dat); PRIVATE char *formscan (char *str, forminfo *fmptr); PRIVATE int isformdir (int ch); PRIVATE truc basesym, groupsym, columsym, digssym; PRIVATE truc setpbsym, getpbsym; PRIVATE truc itoasym, ftoasym, ecvtsym; PRIVATE int quotemode = 1; PRIVATE FILE *outfile; PRIVATE FILE *logfile; PRIVATE int MaxCols; PRIVATE int PrintCols; PRIVATE int PrintPrec; #define DECprec(prec) ((prec)*95 - 10)/20 /*------------------------------------------------------------------*/ PUBLIC void iniprint(cols) int cols; { truc write_sym, writln_sym; if(cols >= MAXCOLS/2 && cols <= 2*MAXCOLS) MaxCols = cols; else MaxCols = MAXCOLS; PrintCols = MaxCols-1; PrintPrec = deffltprec(); write_sym = new0symsig("write",sFBINARY,(wtruc)F1write, s_1u); writesym = newsym("write", sPARSAUX, write_sym); writln_sym= new0symsig("writeln",sFBINARY,(wtruc)Fwritln,s_0u); writlnsym = newsym("writeln", sPARSAUX, writln_sym); basesym = newsym("base", sUNBOUND, nullsym); groupsym = newsym("group", sUNBOUND, nullsym); columsym = newsym("columns", sUNBOUND, nullsym); digssym = newsym("digits", sUNBOUND, nullsym); formatsym = newintsym("", sFBINARY, (wtruc)Gformat); setpbsym = newsymsig("set_printbase",sFBINARY,(wtruc)Fsetpbase,s_ii); getpbsym = newsymsig("get_printbase",sFBINARY,(wtruc)Fgetpbase,s_0); transcsym = newsymsig("transcript", sFBINARY,(wtruc)Ftranscript, s_01); itoasym = newsymsig("itoa", sFBINARY, (wtruc)Fint2str, s_12); ftoasym = newsymsig("ftoa", sFBINARY, (wtruc)Fflt2str, s_1); ecvtsym = newsymsig("float_ecvt",sSBINARY,(wtruc)Secvt, s_4); } /*------------------------------------------------------------------*/ PRIVATE ifun putcfun(strom) truc strom; { outfile = STREAMfile(strom); if(Log_on && (strom == tstdout || strom == tstderr)) return(log2out); else { if ((strom == tstdout || strom == tstderr)) #ifdef genWinGUI return(wincharout); #else return(charoutf); #endif else return(charout); } } /*------------------------------------------------------------------*/ PRIVATE int charout(ch) int ch; { return putc(ch,outfile); } /*------------------------------------------------------------------*/ PRIVATE int charoutf(ch) int ch; { int ret = putc(ch,outfile); fflush(outfile); return ret; } /*------------------------------------------------------------------*/ PUBLIC int logout(ch) int ch; { return putc(ch,logfile); } /*------------------------------------------------------------------*/ PRIVATE int log2out(ch) int ch; { int ret; putc(ch,logfile); #ifdef genWinGUI return wincharout(ch); #else ret = putc(ch,stdout); fflush(stdout); return ret; #endif } /*-------------------------------------------------------------------*/ PUBLIC void strlogout(str) char *str; { int ch; while((ch = *str++)) logout(ch); } /*------------------------------------------------------------------*/ PRIVATE truc Ftranscript(argn) int argn; { char name[84]; char *logname = "aribas"; char *extens = ".log"; char *str; int strerr; if(argn == 1 && *argStkPtr == zero) { closelog(); return(zero); } if(argn == 1) { if(*FLAGPTR(argStkPtr) == fSTRING) { str = STRINGPTR(argStkPtr); strerr = (str[0] ? 0 : 1); } else strerr = 1; if(strerr) { error(transcsym,err_str,*argStkPtr); return(brkerr()); } } else str = logname; fnextens(str,name,extens); logfile = fopen(name,"w"); if(logfile == NULL) { error(transcsym,err_open,scratch(name)); return(false); } else { Log_on = 1; return(true); } } /*-------------------------------------------------------------------*/ PUBLIC void flushlog() { if(Log_on) fflush(logfile); } /*------------------------------------------------------------------*/ PUBLIC void closelog() { if(Log_on) { Log_on = 0; fclose(logfile); } } /*------------------------------------------------------------------*/ PRIVATE truc F1write(argn) /* to avoid name clash with system function */ int argn; { int n = Gprint(argn,0); return(mksfixnum(n)); } /*------------------------------------------------------------------*/ PRIVATE truc Fwritln(argn) int argn; { int n = Gprint(argn,1); return(mksfixnum(n)); } /*------------------------------------------------------------------*/ #define MAXINT2STRLEN 4000 PRIVATE truc Fint2str(argn) int argn; { truc *argptr; truc strobj; word2 *x, *y; char *cpt; long nn; int flg, len, len1, sign, base; int bpd, dig; int errflg = 0; argptr = argStkPtr - argn + 1; flg = *FLAGPTR(argptr); if(flg != fFIXNUM && flg != fBIGNUM) { error(itoasym,err_int,*argptr); return(brkerr()); } if(argn == 2) { if(*FLAGPTR(argStkPtr) != fFIXNUM) errflg = 1; base = *WORD2PTR(argStkPtr); if(base != 10 && base != 16 && base != 2 && base != 8) errflg = 1; if(errflg) { error(itoasym,err_pbase,*argStkPtr); return(brkerr()); } } else base = 10; x = AriBuf; y = (base == 10 ? AriScratch : x); len = bigretr(argptr,y,&sign); if(len == 0) return(mkstr("0")); if(len > MAXINT2STRLEN) { error(itoasym,err_2big,voidsym); return(brkerr()); } if(base == 10) { len = big2bcd(y,len,x); len = (len + 3) >> 2; } if(base >= 10) /* base == 16 || base == 10 */ bpd = 4; else if(base == 8) { x[len] = 0; /* !!! */ bpd = 3; } else /* base == 2 */ bpd = 1; nn = bit_length(x,len); nn = (nn + bpd - 1)/bpd; /* Anzahl der Ziffern */ len1 = (sign ? nn+1 : nn); strobj = mkstr0(len1); cpt = STRING(strobj); if(sign) *cpt++ = '-'; while(--nn >= 0) { dig = nibndigit(bpd,x,nn); *cpt++ = hexascii(dig); } return strobj; } #undef MAXINT2STRLEN /*------------------------------------------------------------------*/ PRIVATE truc Fflt2str() { forminfo fmt; int prec, flg; char *out; flg = chknum(ftoasym,argStkPtr); if(flg == aERROR) return(brkerr()); prec = fltprec(flg); fmt.mode = 'G'; fmt.param[0] = 0; fmt.param[1] = DECprec(prec); out = (char *)AriBuf; float2str(*argStkPtr,out,&fmt,AriScratch); return(mkstr(out)); } /*------------------------------------------------------------------*/ PRIVATE truc Secvt() { numdata acc; truc res; word2 *x; char *cpt ; int k, len, digs, digsmax, decpos, sign, flg; int errflg = 0; acc.digits = x = AriBuf; res = eval(ARGNPTR(evalStkPtr,1)); ARGpush(res); res = eval(ARGNPTR(evalStkPtr,2)); ARGpush(res); flg = *FLAGPTR(argStkPtr-1); if(flg < fFIXNUM) { error(ecvtsym,err_num,argStkPtr[-1]); errflg = 1; goto cleanup; } flg = *FLAGPTR(argStkPtr); if(flg != fFIXNUM) { error(ecvtsym,err_int,*argStkPtr); errflg = 1; goto cleanup; } digs = *WORD2PTR(argStkPtr); if(digs < 2) digs = 2; else if(digs > (digsmax = FltPrec[MaxFltLevel] * 5)) digs = digsmax; len = float2bcd(digs,argStkPtr-1,&acc,AriScratch); sign = (acc.sign ? -1 : 0); decpos = (len ? len + acc.expo : 0); res = mkstr0(digs); cpt = STRING(res); for(k=len-1; k>=0; k--) *cpt++ = nibascii(x,k); for(k=digs-len; k>0; k--) *cpt++ = '0'; Lvalassign(ARGNPTR(evalStkPtr,3),mksfixnum(decpos)); Lvalassign(ARGNPTR(evalStkPtr,4),mksfixnum(sign)); cleanup: if(errflg) res = brkerr(); ARGnpop(2); return(res); } /*------------------------------------------------------------------*/ /* ** Auswertung der Format-Anweisung bei write oder writeln ** argStkPtr[-1]: zu schreibendes Objekt, ** argStkPtr[0]: Tupel mit Formatangaben ** Zurueckgegeben wird ein Tupel, dessen 0-te Komponente ** das Objekt und die weiteren Komponenten die ausgewerteten ** Formatangaben sind. Falls die Formatangaben nicht ** sinnvoll sind, wird nur das Objekt zurueckgegeben. */ PRIVATE truc Gformat() { truc *arr, *ptr; truc obj, grp, bas, wid, dig; int i, m, n; int flg; flg = *FLAGPTR(argStkPtr-1); arr = workStkPtr + 1; WORKpush(argStkPtr[-1]); ptr = VECTORPTR(argStkPtr); m = *VECLENPTR(argStkPtr); for(i=0; i= fFLTOBJ) { n = (m > 1 ? 3 : 2); for(i=1; i= fINTTYPE0 && flg <= fINTTYPE1) || flg == fBYTESTRING) { if(m < 4) for(i=m; i<4; i++) WORKpush(zero); bas = wid = dig = zero; grp = nullsym; n = 2; for(i=1; i<=m; i++) { if(*FLAGPTR(arr+i) == fFUNCALL) { ptr = TAddress(arr+i); if(*ptr == basesym) { if(n < 3) n = 3; if(ptr[1] == constone) { obj = eval(ptr+2); if(Tflag(obj) == fFIXNUM) bas = obj; } continue; } else if(*ptr == groupsym) { if(n < 4) n = 4; if(ptr[1] == constone) { obj = eval(ptr+2); if(Tflag(obj) == fFIXNUM) grp = obj; } continue; } else if(*ptr == digssym) { if(n < 5) n = 5; if(ptr[1] == constone) { obj = eval(ptr+2); if(Tflag(obj) == fFIXNUM) dig = obj; } continue; } } obj = eval(arr+i); if(Tflag(obj) == fFIXNUM) wid = obj; } arr[1] = wid; arr[2] = bas; arr[3] = grp; arr[4] = dig; } else if(flg == fSTRING || flg == fCHARACTER) { /* fehlt Analyse von escape Anweisungen */ arr[1] = eval(arr+1); if(*FLAGPTR(arr+1) != fFIXNUM) n = 0; else n = 2; } else if(flg == fSTREAM) { n = 0; if(*FLAGPTR(arr+1) == fFUNCALL) { ptr = TAddress(arr+1); if(*ptr == columsym) { if(ptr[1] == constone) { obj = eval(ptr+2); if(Tflag(obj) == fFIXNUM) { arr[1] = obj; n = 2; } } } } } else n = 0; obj = (n ? mkntuple(fTUPLE,arr,n) : arr[0]); workStkPtr = arr - 1; return(obj); } /*------------------------------------------------------------------*/ PRIVATE int Gprint(argn,nl) int argn; int nl; { truc *ptr; truc strom; truc obj; int changecols = 0; int savemode, flg; int i; strom = tstdout; if(argn > 0) { ptr = argStkPtr - argn + 1; flg = *FLAGPTR(ptr); if(flg == fTUPLE) { obj = *ptr; if(*VECLENPTR(ptr) >= 2) { ptr = VECTOR(obj); flg = *FLAGPTR(ptr); changecols = 1; } } if(flg == fSTREAM) { if(!isoutfile(ptr,aTEXT)) { error(writesym,err_tout,voidsym); return(-1); } else { argn--; strom = *ptr; } if(changecols) { PrintCols = setcols(strom,ptr+1); } } } savemode = quotemode; quotemode = 0; for(i=-argn+1; i<=0; i++) { tprint(strom,argStkPtr[i]); } if(nl) fnewline(strom); quotemode = savemode; PrintCols = MaxCols-1; return(argn); } /*------------------------------------------------------------------*/ PRIVATE int setcols(strom,ptr) truc strom; truc *ptr; { unsigned k; if(*FLAGPTR(ptr) != fFIXNUM) return(MaxCols-1); k = *WORD2PTR(ptr); if(k < MAXCOLS/4) k = MAXCOLS/4; else if(k > IOBUFSIZE) k = IOBUFSIZE; return(k); } /*------------------------------------------------------------------*/ PUBLIC void tprint(strom,obj) truc strom, obj; { forminfo fmt; truc *ptr; int m, flg, len; flg = Tflag(obj); if(flg == fTUPLE) { /* Format-Angaben */ ptr = VECTOR(obj); m = VEClen(obj); flg = *FLAGPTR(ptr); obj = ptr[0]; getform(&fmt,obj,ptr+1,m-1); } else { /* default format */ getform(&fmt,obj,NULL,0); } if(flg == fSYMBOL) len = sym2str(obj,OutBuf); else if(flg == fBIGNUM || flg == fFIXNUM) { printfint(strom,obj,&fmt); return; } else if(flg == fGF2NINT) { printfint(strom,obj,&fmt); return; } else if(flg >= fFLTOBJ) { printfloat(strom,obj,&fmt); return; } else if(flg == fCHARACTER) { len = char2str(obj,OutBuf,&fmt); } else if(flg == fBOOL) { len = bool2str(obj,OutBuf); } else if(flg == fSTRING) { printstring(strom,obj,&fmt); return; } else if(flg == fBYTESTRING) { printbstring(strom,obj,&fmt); return; } else if(flg == fVECTOR) { printvector(strom,obj); return; } else if(flg == fRECORD) { printrecord(strom,obj); return; } else if(flg == fPOINTER) { len = ptr2str(obj,OutBuf); } else len = obj2str(flg,obj,OutBuf); fprintmarg(strom,OutBuf,len); } /*--------------------------------------------------------------*/ PRIVATE void getform(fptr,obj,arr,n) forminfo *fptr; truc obj; truc *arr; int n; { int x; int prec, len, base, group, digs; int flg = Tflag(obj); if(n >= 1) { x = *WORD2PTR(arr); if(x > PrintCols-1) x = PrintCols - 1; if(*SIGNPTR(arr)) x = -x; fptr->param[0] = x; /* Gesamt-Breite */ } else { fptr->param[0] = 0; /* default */ } if(flg >= fFLTOBJ) { prec = fltprec(flg); if(fptr->param[0] == 0 && PrintPrec && prec > PrintPrec) prec = PrintPrec; if(n <= 1) { fptr->mode = (n==0 ? 'G' : 'E'); fptr->param[1] = DECprec(prec); } else { fptr->mode = 'F'; fptr->param[2] = DECprec(prec); x = *WORD2PTR(arr+1); if(x < 1) x = 1; else if(x > FltPrec[MaxFltLevel]*5) x = FltPrec[MaxFltLevel]*5; fptr->param[1] = x; /* Stellen nach dem Dezimalpunkt */ } } else if(flg == fFIXNUM || flg == fBIGNUM || flg == fGF2NINT) { if(n <= 1) base = printbase(0); else if(n >= 2) { base = *WORD2PTR(arr+1); base = admissbase(base); } if(flg == fGF2NINT) { if(base == 10) base = 16; } if(n < 3 || arr[2] == nullsym) { if(flg == fBIGNUM || flg == fGF2NINT) len = VEClen(obj); else len = 1; switch(base) { case 16: group = (len > 2 ? 4 : 8); break; case 8: group = 5; break; case 2: group = 8; break; default: /* base == 10 */ group = (len > 2 ? 5 : 10); break; } } else group = *WORD2PTR(arr+2); if(n >= 4) digs = *WORD2PTR(arr+3) & 0x7FFF; else digs = 0; fptr->param[1] = base; fptr->param[2] = group; fptr->param[3] = digs; } else if(flg == fBYTESTRING) { if(n < 3 || arr[2] == nullsym) group = 4; else group = *WORD2PTR(arr+2); fptr->param[2] = group; } else { fptr->mode = flg; if(n > 1) /* vorlaeufig */ n = 1; fptr->param[n] = DEFAULT; } } /*--------------------------------------------------------------*/ PRIVATE truc Fsetpbase() { int flg; int base; int errflg = 0; flg = *FLAGPTR(argStkPtr); if(flg != fFIXNUM) errflg = 1; else { base = *WORD2PTR(argStkPtr); if(base == 16 || base == 10 || base == 8 || base == 2) printbase(base); else { errflg = 1; } } if(errflg) { base = printbase(0); error(setpbsym,err_pbase,*argStkPtr); } return(mkfixnum(base)); } /*--------------------------------------------------------------*/ PRIVATE truc Fgetpbase() { return(mkfixnum(printbase(0))); } /*--------------------------------------------------------------*/ PRIVATE int admissbase(base) int base; { switch(base) { case 2: case 8: case 10: case 16: return(base); default: return(printbase(0)); } } /*--------------------------------------------------------------*/ PRIVATE int printbase(base) int base; { static int pbase = 10; switch(base) { case 2: case 8: case 10: case 16: pbase = base; return(base); default: return(pbase); } } /*--------------------------------------------------------------*/ PUBLIC int setprnprec(prec) int prec; { int prec1; if(prec < 0) return(PrintPrec); /* else */ prec1 = maxfltprec(); if(prec > prec1) prec = prec1; return (PrintPrec = prec); } /*--------------------------------------------------------------*/ PRIVATE char *baseprefix(base, mode) int base, mode; { static char pref[4]; switch(base) { case 16: strcopy(pref,"0x"); break; case 8: strcopy(pref,"0o"); break; case 2: strcopy(pref,"0y"); break; default: pref[0] = '\0'; } if(mode == 2 && strlen(pref) > 1) pref[0] = '2'; return pref; } /*--------------------------------------------------------------*/ /* ** formatted output of integers */ PRIVATE void printfint(strom,obj,fptr) truc strom, obj; forminfo *fptr; { truc big; word2 *x; char *cpt; long nn, NN, nn1, nn2, pp, m; int sign, len, base, width, grp, noofdigs; int k, n, bpd; int diff = 0; int dig; int rightpad; int mode; big = obj; len = bigretr(&big,AriBuf,&sign); base = fptr->param[1]; if(base == 10) { len = big2bcd(AriBuf,len,AriScratch); len = (len + 3)>>2; x = AriScratch; } else { x = AriBuf; } width = fptr->param[0]; grp = fptr->param[2]; if(grp == 0) grp = 1; else if(grp == 1) grp = 2; else if(grp > PrintCols-1) grp = PrintCols-1; noofdigs = fptr->param[3]; if(len == 0 && noofdigs == 0) noofdigs = 1; if(base >= 10) { bpd = 4; } else if(base == 8) { x[len] = 0; /* !!! */ bpd = 3; } else bpd = 1; nn = bit_length(x,len); nn = (nn + bpd - 1)/bpd; /* Anzahl der Ziffern ohne leading 0 */ NN = (noofdigs > nn ? noofdigs : nn); pp = (NN + grp - 1)/grp; /* Zahl der Bloecke */ k = NN - (pp-1)*grp; /* Zahl der Ziffern im 1.Block */ n = (sign ? strcopy(OutBuf,"-") : 0); if(quotemode) { mode = (FLAG(big) == fGF2NINT ? 2 : 0); n += strcopy(OutBuf+n,baseprefix(base,mode)); } m = NN + n + (grp==1 ? 0 : (pp-1)); rightpad = 0; if(width > 0 && m < width) { diff = width - m; OutBuf[n] = 0; n = leftpad(OutBuf,n+diff,' '); } else if(width < 0 && m < -width) { diff = -width - m; rightpad = 1; } while(--pp >= 0) { cpt = OutBuf + n; nn2 = pp * grp; for(nn1 = nn2+k-1; nn1 >= nn2; nn1--) { if(nn1 >= nn) dig = 0; else dig = nibndigit(bpd,x,nn1); *cpt++ = hexascii(dig); } if(pp > 0 && grp > 1) *cpt++ = '_'; *cpt = 0; n = cpt - OutBuf; fprintmarg(strom,OutBuf,n); n = 0; k = grp; } if(rightpad) { fillspaces(OutBuf,diff); fprintstr(strom,OutBuf); } } /*--------------------------------------------------------------*/ PRIVATE int nibasci0(x,k) word2 *x; int k; { if(k >= 0) return nibascii(x,k); else return '0'; } /*--------------------------------------------------------------*/ /* ** prints float obj ** uses AriBuf and ScratchBuf */ PRIVATE void printfloat(strom,obj,fptr) truc strom, obj; forminfo *fptr; { numdata acc; truc fltnum; word2 *x; char *cpt; long decpos, expo; int k, len, digs, dec, width, sign, mode; int eflg; int grp=5; mode = fptr->mode; width = fptr->param[0]; if(mode == 'G' || mode == 'E') { digs = fptr->param[1]; } else { /* mode == 'F' */ dec = fptr->param[1]; digs = fptr->param[2]; } if(width > 0 && width <= PrintCols-1) { /* vorlaeufig */ len = float2str(obj,OutBuf,fptr,AriScratch); fprintmarg(strom,OutBuf,len); return; } /* else */ acc.digits = x = AriBuf; fltnum = obj; len = float2bcd(digs,&fltnum,&acc,AriScratch); sign = (acc.sign ? -1 : 0); decpos = (len ? len + acc.expo : 0); if(decpos <= grp && decpos > -grp) { eflg = 0; } else { eflg = 1; expo = decpos - 1; decpos = 1; } if(digs < 20) /* vorlaeufig */ grp = 20; /* print head */ cpt = OutBuf; if(sign) *cpt++ = '-'; if(decpos <= 0) { cpt += strcopy(cpt,"0."); for(k=0; k>=decpos+1; k--) *cpt++ = '0'; for(k=decpos; (k>-grp) && (--digs>=0); k--) *cpt++ = nibasci0(x,--len); } else { /* decpos > 0 */ for(k=decpos; (k>0) && (--digs>=0); k--) *cpt++ = nibasci0(x,--len); *cpt++ = '.'; for(k=0; (k=0); k++) *cpt++ = nibasci0(x,--len); } if(digs > 0) *cpt++ = '_'; *cpt = 0; fprintmarg(strom,OutBuf,strlen(OutBuf)); /* print next groups */ while(digs > 0) { cpt = OutBuf; for(k=0; (k=0); k++) *cpt++ = nibasci0(x,--len); if(digs > 0) *cpt++ = '_'; *cpt = 0; fprintmarg(strom,OutBuf,strlen(OutBuf)); } if(eflg) { k = s1form(OutBuf,"e~D",intcast(expo)); fprintmarg(strom,OutBuf,k); } } /*--------------------------------------------------------------*/ PRIVATE int printvector(strom,obj) truc strom, obj; { return(printvvrr(strom,obj,fVECTOR)); } /*--------------------------------------------------------------*/ PRIVATE int printrecord(strom,obj) truc strom, obj; { return(printvvrr(strom,obj,fRECORD)); } /*--------------------------------------------------------------*/ /* ** Ausgabe von Arrays und Records */ PRIVATE int printvvrr(strom,obj,flg) truc strom, obj; int flg; { static char *brace[] = {"(","{","&("}; static char *closebrace[] = {")","}",")"}; truc *ptr; int braceno; int savemode; int n, len; int pos; savemode = quotemode; quotemode = 1; WORKpush(obj); n = len = *VECLENPTR(workStkPtr); ptr = VECTORPTR(workStkPtr); if(flg == fRECORD) { ptr++; braceno = 2; } else if(len == 1) braceno = 1; else braceno = 0; fprintmarg(strom,brace[braceno],5); while(--n >= 0) { tprint(strom,*ptr); if(n) { fprintch(strom,','); pos = STREAMpos(strom); if(pos >= 1 && pos <= PrintCols - 1) fprintch(strom,' '); } if((n & 0xF) == 0 && INTERRUPT) { setinterrupt(0); len = strcopy(OutBuf,"...user interrupt... "); fprintmarg(strom,OutBuf,len); break; } ptr++; } WORKpop(); fprintmarg(strom,closebrace[braceno],2); quotemode = savemode; return(len); } /*--------------------------------------------------------------*/ PRIVATE void printstring(strom,obj,fptr) truc strom, obj; forminfo *fptr; { struct strcell *strpt; char *s; unsigned len; int width, fill; int align; strpt = stringptr(obj); len = strpt->len; s = (char *)AriScratch; strnfcopy(s,&(strpt->ch0),len); /**** fehlt Behandlung nichtdruckbarer Zeichen *****/ width = fptr->param[0]; if(width >= 0) { align = 1; } else { align = -1; width = -width; } if(width > len) fill = width - len; else align = 0; if(fill >= PrintCols) align = 0; if(align == 0) { fill = 0; width = len; } if(quotemode) /* only in unformatted mode */ width += 2; if(STREAMpos(strom) >= PrintCols-width) fnewline(strom); if(quotemode) { fprintch(strom,'"'); fprintwrap(strom,s,PrintCols-1,'\\'); fprintch(strom,'"'); } else { if(align <= 0) fprintwrap(strom,s,PrintCols,0); if(align) { fillspaces(OutBuf,fill); fprintstr(strom,OutBuf); } if(align > 0) fprintwrap(strom,s,PrintCols,0); } } /*--------------------------------------------------------------*/ /* ** print byte string in hex format */ PRIVATE void printbstring(strom,obj,fptr) truc strom,obj; forminfo *fptr; { struct strcell *strpt; byte *buf; size_t k = 0, len; int n = 0, m, grp; int weiter = 1; strpt = stringptr(obj); buf = (byte *)&(strpt->ch0); len = strpt->len; grp = fptr->param[2]; if(grp == 1) grp = 2; else if(grp > PrintCols-1) grp = PrintCols-1; if(quotemode) n = strcopy(OutBuf,"$"); while(weiter) { m = (grp ? grp/2 : 2); if(k+m > len) m = (k <= len ? len-k : 0); n += bytes2hex(OutBuf+n,buf+k,m); if(k+m < len) { if(grp) n += strcopy(OutBuf+n,"_"); k += m; } else weiter = 0; fprintmarg(strom,OutBuf,n); n = 0; } } /*--------------------------------------------------------------*/ PRIVATE int bytes2hex(str,buf,len) char *str; byte *buf; int len; { unsigned u; int i; for(i=0; i> 4) & 0x0F); *str++ = hexascii(u & 0x0F); } *str = 0; return(2*len); } /*--------------------------------------------------------------*/ /* ** kopiert fromstr nach tostr ** Rueckgabewert: Laenge des Strings */ PUBLIC int strcopy(tostr,fromstr) char *tostr, *fromstr; { int i=0; while((*tostr++ = *fromstr++)) i++; return(i); } /*--------------------------------------------------------------*/ /* ** kopiert hoechstens maxlen characters von fromstr nach tostr ** und setzt in diesen den Endmarkierer '\0' ** Rueckgabewert: Laenge des neuen Strings */ PUBLIC int strncopy(tostr,fromstr,maxlen) char *tostr, *fromstr; int maxlen; { int i=0; while((*tostr++ = *fromstr++)) { if(++i >= maxlen) { *tostr = 0; break; } } return(i); } /*--------------------------------------------------------------*/ /* ** kopiert len Zeichen von fromstr nach tostr, wobei jedes Nullbyte ** durch SPACE ersetzt wird. tostr wird durch Nullbyte abgeschlossen */ PRIVATE void strnfcopy(tostr,fromstr,len) char *tostr, *fromstr; unsigned len; { int ch; while(len--) { ch = *fromstr++; *tostr++ = (ch ? ch : ' '); } *tostr = 0; } /*--------------------------------------------------------------*/ PRIVATE int sym2str(obj,buf) truc obj; char *buf; { return(strncopy(buf,SYMname(obj),PrintCols-1)); } /*--------------------------------------------------------------*/ PRIVATE int float2str(obj,buf,fptr,hilf) truc obj; char *buf; forminfo *fptr; word2 *hilf; { numdata acc; truc fltnum; long expo; word2 *scratch; int len,len1,n,fill; int mode, width, wd1, prec, prec1, dec; acc.digits = hilf; mode = fptr->mode; width = fptr->param[0]; if(mode == 'G' || mode == 'E') { prec = fptr->param[1]; } else { /* mode == 'F' */ dec = fptr->param[1]; prec = fptr->param[2]; } fltnum = obj; scratch = hilf + 4 + (prec/4); len = float2bcd(prec,&fltnum,&acc,scratch); if(mode == 'F') { len1 = len + acc.expo + dec + 1; if(len1 <= width || len1 <= prec-1) { prec1 = prec + dec + acc.expo; if(prec1 < prec) roundbcd(prec1,&acc); wd1 = fixstring(&acc,dec,buf); width = leftpad(buf,width,' '); return(width); } else { mode = 'G'; } } if(mode == 'E') { if(width-8 >= prec) { dec = prec - 1; } else if(width >= 10) { dec = width - 9; } else { dec = 1; width = 10; } len = roundbcd(dec+1,&acc); expo = (len ? acc.expo + dec : 0); acc.expo = -dec; fill = width - dec - 9; if(acc.sign == 0) fill++; buf += fillspaces(buf,fill); wd1 = fixstring(&acc,dec,buf); buf[wd1] = 'e'; n = long2s0alfa(buf+wd1+1,expo,5); return(fill+wd1+1+n); } if(len > 0) { /* mode == 'G' */ if(acc.expo <= -1 && acc.expo >= -prec - 2) { dec = -acc.expo; n = fixstring(&acc,dec,buf); } else { expo = acc.expo + prec - 1; acc.expo = -prec + 1; n = fixstring(&acc,prec-1,buf); n += s1form(buf+n,"e~D",intcast(expo)); } } else { n = strcopy(buf,"0.0"); } return(n); } /*--------------------------------------------------------------*/ /* ** Schreibt die in *nptr gegebene Float-Zahl als fixed-point-string ** mit dec Dezimalstellen hinter dem Komma in buf. ** Rueckgabewert Laenge des Strings. */ PRIVATE int fixstring(nptr,dec,buf) numdata *nptr; int dec; char *buf; { word2 *x; char *cpt; int len, k, sh; cpt = buf; if(nptr->sign) *cpt++ = '-'; len = nptr->len; x = nptr->digits; if(len > 0) { sh = dec + nptr->expo; len = shiftbcd(x,len,sh); } if(len <= dec) { /* '0' vor dem Dezimalpunkt */ *cpt++ = '0'; *cpt++ = '.'; for(k=dec-1; k>=len; k--) *cpt++ = '0'; for(k=len-1; k>=0; k--) *cpt++ = nibascii(x,k); } else { /* len-dec Stellen vor dem Dezimalpunkt */ for(k=len-1; k>=dec; k--) *cpt++ = nibascii(x,k); *cpt++ = '.'; for(k=dec-1; k>=0; k--) *cpt++ = nibascii(x,k); } *cpt = 0; return(cpt-buf); } /*--------------------------------------------------------------*/ PRIVATE int char2str(obj,buf,fptr) truc obj; char *buf; forminfo *fptr; { variant v; int k, ch, len, width; v.xx = obj; ch = v.pp.ww; if(quotemode) { if(ch < ' ' || ch == 127) { len = s1form(buf,"chr(~D)",intcast(ch)); } else { len = s1form(buf,"'~C'",intcast(ch)); } return(len); } if(!ch) ch = ' '; width = fptr->param[0]; if(width == 0) len = 1; else len = (width > 0 ? width : -width); fillspaces(buf,len); k = (width >= 0 ? len-1 : 0); buf[k] = ch; return(len); } /*--------------------------------------------------------------*/ PRIVATE int bool2str(obj,buf) truc obj; char *buf; { obj = (obj == true ? truesym : falsesym); return(strcopy(buf,SYMname(obj))); } /*--------------------------------------------------------------*/ /* ** Verwandelt ein truc obj = (b0,b1: byte; ww: word2) in ein word4, ** so dass b0 das most significant byte wird */ PRIVATE word4 truc2msf(obj) truc obj; { variant v; word4 u; v.xx = (word4)obj; u = v.pp.b0; u = (u << 8)|v.pp.b1; u = (u << 16)|v.pp.ww; return(u); } /*--------------------------------------------------------------*/ PRIVATE int ptr2str(obj,buf) truc obj; char *buf; { obj = PTRtarget(obj); if(obj == nil) return(strcopy(buf,SYMname(nil))); return(s1form(buf,"",intcast(truc2msf(obj)))); } /*--------------------------------------------------------------*/ PRIVATE int obj2str(flg,obj,buf) int flg; truc obj; char *buf; { word4 u; char *str; u = truc2msf(obj); switch(flg) { case fSTACK: str = "STACK"; break; case fFUNDEF: str = "FUNCTION"; break; case fSTREAM: u = (word4)STREAMfile(obj); str = "STREAM"; break; default: if(flg >= fSPECIAL1 && flg <= fBUILTINn) { str = "PROC"; } else str = "OBJECT"; } return(s2form(buf,"<~A:~X>",strcast(str),intcast(u))); } /*--------------------------------------------------------------*/ PRIVATE int leftpad(buf,width,ch) char *buf; int width; int ch; { int i, diff; int len = strlen(buf); diff = width - len; if(diff <= 0) return(len); for(i=len; i>=0; i--) buf[diff+i] = buf[i]; for(i=0; i= ' ') { i++; } else { if((ch == EOL) || (ch == '\r')) i = 0; else if(ch == '\b') i = (i > 0 ? i-1 : 0); else if(ch == '\t') i = (i | 0x3) + 1; else if(ch) i++; } if(i >= bound) { i = 0; if(contmark) writech(contmark); writech(EOL); } } STREAMpos(strom) = i; return(n); } /*--------------------------------------------------------------*/ PRIVATE int fprintmarg(strom,str,len) truc strom; char *str; int len; { if(STREAMpos(strom) >= PrintCols-len) fnewline(strom); return fprintwrap(strom,str,PrintCols,0); } /*--------------------------------------------------------------*/ PUBLIC void fprintline(strom,str) truc strom; char *str; { fprintwrap(strom,str,PrintCols,0); fnewline(strom); } /*--------------------------------------------------------------*/ PUBLIC void fnewline(strom) truc strom; { ifun writech; writech = putcfun(strom); writech(EOL); STREAMpos(strom) = 0; } /*--------------------------------------------------------------*/ PUBLIC void ffreshline(strom) truc strom; { if(STREAMpos(strom) != 0) fnewline(strom); } /*--------------------------------------------------------------*/ PUBLIC void flinepos0(strom) truc strom; { STREAMpos(strom) = 0; } /*--------------------------------------------------------------*/ PRIVATE int fprintch(strom,ch) truc strom; int ch; { ifun writech; writech = putcfun(strom); if(STREAMpos(strom) >= PrintCols || ch == EOL) { writech(EOL); STREAMpos(strom) = 0; } if(ch != EOL) { writech(ch); STREAMpos(strom) += 1; } return(STREAMpos(strom)); } /*--------------------------------------------------------------*/ PRIVATE int long2alfa(buf,u) char *buf; long u; { word2 x[2], y[3]; int n, s = 0; if(u < 0) { u = - u; *buf++ = '-'; s = 1; } n = long2big(u,x); n = big2bcd(x,n,y); return(bcd2str(y,n,buf) + s); } /*--------------------------------------------------------------*/ PRIVATE int long2s0alfa(buf,u,len) char *buf; long u; int len; { word2 x[2], y[3]; int i,n; int m = 0, s = 0; if(u < 0) { u = - u; s = 1; } n = long2big(u,x); n = big2bcd(x,n,y); if(s || n < len) { *buf++ = (s ? '-' : '+'); m++; } for(i=n+m; i 0) bcd2str(y,n,buf); else *buf = 0; return(n + m); } /*--------------------------------------------------------------*/ PRIVATE int word4xalfa(buf,u) char *buf; word4 u; { word2 x[2]; int n; n = long2big(u,x); return(big2xstr(x,n,buf)); } /*--------------------------------------------------------------*/ PUBLIC wtruc strcast(str) char *str; { return (wtruc)str; } /*--------------------------------------------------------------*/ PUBLIC wtruc intcast(x) long x; { return (wtruc)x; } /*--------------------------------------------------------------*/ PUBLIC int s1form(buf,fmt,dat) char *buf; char *fmt; wtruc dat; { return(s2form(buf,fmt,dat,dat)); } /*--------------------------------------------------------------*/ PUBLIC int s2form(buf,fmt,dat1,dat2) char *buf; char *fmt; wtruc dat1, dat2; { forminfo finf; char *fmt1; wtruc dat; int mode; int n = 0; int count = 0; while((fmt1 = formscan(fmt,&finf))) { mode = finf.mode; if(mode == 0) { n += strncopy(buf+n,fmt,finf.param[0]); } else if(mode == '%') { n += strcopy(buf+n,"\n"); } else if(mode == aERROR) { buf[n] = 0; break; } else { if(++count > 2) break; dat = (count == 1 ? dat1 : dat2); n += sformaux(&finf,buf+n,dat); } fmt = fmt1; } return(n); } /*--------------------------------------------------------------*/ /* ** Unterstuetzte Optionen: ** ~A string, ~D long int, ~X long hex, ~C character ** */ PRIVATE int sformaux(fmptr,buf,dat) forminfo *fmptr; char *buf; wtruc dat; { char *ptr1, *ptr2; int i, len, width, mode; long intdat; char fill; mode = fmptr->mode; switch(mode) { case 'A': ptr1 = (char *)dat; len = strcopy(buf,ptr1); break; case 'D': intdat = (long)dat; len = long2alfa(buf,intdat); break; case 'X': intdat = (long)dat; len = word4xalfa(buf,(word4)intdat); break; case 'C': intdat = (long)dat; buf[0] = (char)intdat; buf[1] = 0; len = 1; break; default: buf[0] = 0; return(0); } width = fmptr->param[0]; if(width > len) { fill = fmptr->param[1]; ptr2 = buf + width; ptr1 = buf + len; for(i=0; i<=len; i++, ptr1--, ptr2--) *ptr2 = *ptr1; for(i=len; iparam[n] = NOTSET; if(*str != '~') { fmptr->mode = 0; for(n=1; (ch=*++str); n++) if(ch == '~') break; fmptr->param[0] = n; return(str); } str++; ch = *str; if(ch == '0') { fmptr->param[1] = '0'; str++; } else { fmptr->param[1] = ' '; } x = str2int(str,&n); fmptr->param[0] = x; str += n; if((ch = isformdir(*str))) { fmptr->mode = ch; return(str + 1); } else { fmptr->mode = aERROR; return(NULL); } } /*--------------------------------------------------------------*/ PRIVATE int isformdir(ch) int ch; { if(ch == 'A' || ch == 'C' || ch == 'D' || ch == 'X' || ch == '%') return(ch); else return(0); } /****************************************************************/ aribas165b/src/README0000644000076600000240000000412414660572534013252 0ustar ottostaff##################################################################### # README file for the directory aribas165/src # Author: O.Forster # Email: forster@mathematik.uni-muenchen.de # Web: http://www.mathematik.uni-muenchen.de/~forster # Date: 2024-08-19 ##################################################################### COMPILATION of ARIBAS (V. 1.65b, Aug. 2024) To compile ARIBAS under UNIX, LINUX or MacOS X, the following 25 files are necessary. a) 23 C-Files alloc.c analysis.c aritaux.c arith.c aritool0.c aritools.c aritx.c arity.c aritz.c array.c control.c errtext.c eval.c file.c mainloop.c mem0.c parser.c print.c scanner.c storage.c syntchk.c sysdep.c terminal.c b) 2 Include-Files logscr.inc (included by terminal.c) common.h (common header file) The c-files must be compiled with the symbol UNiX defined (note the lower case i), so when all the above files (and no other c-files) are in the current directory, the simple command line cc -DUNiX -o aribas *.c will compile aribas (please note the lower case i in UNiX). But you may also use the provided Makefile and compile aribas with the command make If you have problems with system dependent functions (they are concentrated in the file sysdep.c), you may either edit the file sysdep.c according to the needs of your system or try cc -DUNiX -DSysDUM -o aribas *.c This will substitute dummy functions; the ARIBAS function timer and the automatic initialization of the random generator will not work, but everything else will not be affected. INSTALLATION To run ARIBAS, only the executable file aribas is necessary. Move it to a directory which is in the PATH variable. If you want online help, you need also the file aribas.hlp, which must be placed in a directory which is in the PATH variable. There is also an interface to run ARIBAS within the GNU Emacs editor (version 19.xx or higher). The necessary Emacs Lisp file is aribas.el in the subdirectory EL. Please read the corresponding README file. ############################# EOF ################################### aribas165b/src/scanner.c0000644000076600000240000010455614660570650014176 0ustar ottostaff/****************************************************************/ /* file scanner.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** scanner.c ** scanning input ** ** date of last change ** 1995-03-21 ** 1997-01-24 moved skiptobel() to file.c ** 1997-04-11 changed trimblanks() ** 1997-07-04 changed readln to handle multi-line integers ** 1998-04-05 changed readln to handle reading empty strings ** 1998-10-06 readln: corrected handling of EOF ** 1998-11-14 nexttok: handle DOS line endings under UNiX ** 1999-06-15 readln: #ifdef Win32GUI, changed peekchar ** 2004-02-09 numval: corrected value of count */ #include "common.h" PUBLIC void iniscan (void); PUBLIC int nexttok (truc *strom, int skip); PUBLIC int curtok (truc *strom); PUBLIC int fltreadprec (void); PUBLIC int skipeoltok (truc *strom); PUBLIC int isalfa (int ch); PUBLIC int isdigalfa (int ch); PUBLIC int isdecdigit (int ch); PUBLIC int ishexdigit (int ch); PUBLIC int isoctdigit (int ch); PUBLIC int isbindigit (int ch); PUBLIC int toupcase (int ch); PUBLIC int tolowcase (int ch); PUBLIC char *trimblanks (char *str, int mode); PUBLIC int rerror (truc sym1, char *mess, truc sym2); PUBLIC char *StrBuf; /* input buffer */ PUBLIC char *SymBuf; /* buffer for symbol names */ PUBLIC numdata Curnum; /* currently processed number */ PUBLIC truc Curop; /* currently processed operator */ /*------------------------------------------------------------*/ PRIVATE ifun0 chread (truc *strom); PRIVATE ifun0 readfrom (char *str); PRIVATE ifun0 lnread (truc *strom, char *buf); PRIVATE int nextchar (void); PRIVATE int nextstrchar (void); PRIVATE int nextlnchar (void); PRIVATE int tnextchar (void); PRIVATE int peekchar (ifun0 nextch); PRIVATE int isdelim0 (int ch); PRIVATE int isdelim1 (int ch); PRIVATE int skipblanks (int ch, ifun0 nextch); PRIVATE int skipcomment (ifun0 nextch); PRIVATE int histinp (ifun0 nextch, char *buf); PRIVATE int stringinp (ifun0 nextch, char *buf, ifun delimfun); PRIVATE int charinp (ifun0 nextch, char *buf); PRIVATE int symbolchar (int ch); PRIVATE int isbasemark (int ch, int mode); PRIVATE int isexpmark (int ch); PRIVATE int normdecstr (char *str); PRIVATE int digsequence (ifun0 nextch, char *buf, int maxlen); PRIVATE int bstrinp (ifun0 nextch, char *str, int maxlen); PRIVATE int signinp (ifun0 nextch, char *str); PRIVATE int intinp (ifun0 nextch, char *str, int maxlen); PRIVATE int numinp (ifun0 nextch, char *str, int maxlen); PRIVATE int accumint (numdata *nptr); PRIVATE int accumbstr (numdata *nptr); PRIVATE int accumfloat (numdata *nptr); PRIVATE truc Satoi (void); PRIVATE truc Satof (void); PRIVATE truc Snumval (truc symb); PRIVATE int numval (char *str, int *pcount); PRIVATE int readlnitem (ifun0 nextch, truc *ptr); PRIVATE truc Sreadln (void); PRIVATE truc readlnsym, atoisym, atofsym; PRIVATE int curbase; PRIVATE int curfltprec; PRIVATE char *numstring; PRIVATE char *expstring; PRIVATE int expsign; PRIVATE int digsep = '_'; PRIVATE int strbufSize; PRIVATE ifun checkdig; /* current function for checking digits */ PRIVATE FILE *cFil; /* current input file pointer */ PRIVATE struct stream *cStream; /* current input stream */ PRIVATE char *tBufptr = "\n"; /* pointer to next character of terminal input */ PRIVATE char *cStrptr; /* pointer to next character in currently read string */ PRIVATE FILE *rFil; /* readln input file pointer */ PRIVATE char rChar; /* current character during readln */ PRIVATE char *rBuf; /* buffer used during readln */ PRIVATE char *rBufptr; /* pointer to char in rBuf */ PRIVATE int inpsource = TERMINALINP; // #define SCANLOG #ifdef SCANLOG char *slogfile = "scan.log"; FILE *Slog = NULL; int slognum(tok) int tok; { fprintf(Slog,"%d\n",tok); return tok; } int slogmess(mess) char *mess; { fprintf(Slog,"%s",mess); return strlen(mess); } int slogtick(ch) int ch; { fprintf(Slog,"%c",ch); return ch; } #endif /*--------------------------------------------------------------------*/ PUBLIC void iniscan() { StrBuf = (char *)AriBuf; strbufSize = sizeof(word2) * aribufSize - (IOBUFSIZE+4); SymBuf = StrBuf + strbufSize; readlnsym = newsymsig("readln", sSBINARY,(wtruc)Sreadln, s_0u); atoisym = newsymsig("atoi", sSBINARY,(wtruc)Satoi, s_12); atofsym = newsymsig("atof", sSBINARY,(wtruc)Satof, s_12); Curop = nullsym; } /*------------------------------------------------------------*/ PRIVATE ifun0 chread(strom) truc *strom; { cStream = STREAMPTR(strom); cFil = cStream->file; if(cFil == stdin) { inpsource = TERMINALINP; return(tnextchar); } else { inpsource = FILEINPUT; return(nextchar); } } /*------------------------------------------------------------*/ PRIVATE ifun0 lnread(strom,buf) truc *strom; char *buf; { struct stream *strmptr; strmptr = STREAMPTR(strom); rFil = strmptr->file; rBuf = rBufptr = buf; rBuf[0] = rChar = 0; inpsource = READLNINPUT; return(nextlnchar); } /*------------------------------------------------------------*/ PRIVATE ifun0 readfrom(str) char *str; { cStrptr = str; inpsource = STRINGINPUT; return(nextstrchar); } /*------------------------------------------------------------*/ /* ** next character from current input file */ PRIVATE int nextchar() { int ch = fgetc(cFil); if(ch == EOL) cStream->lineno++; return(cStream->ch = ch); } /*------------------------------------------------------------*/ /* ** next character during readln */ PRIVATE int nextlnchar() { int ch; nochmal: ch = *rBufptr; if(ch == 0) { #ifdef Win32GUI if(rFil == stdin) { if(!wingets(rBuf,IOBUFSIZE)) return(rChar = EOF); } else #endif if(!fgets(rBuf,IOBUFSIZE,rFil)) return(rChar = EOF); if(Log_on && rFil == stdin) strlogout(rBuf); rBufptr = rBuf; goto nochmal; } rBufptr++; return(rChar = ch); } /*------------------------------------------------------------*/ /* ** next character from current string stream */ PRIVATE int nextstrchar() { int ch; ch = *cStrptr; if(ch) cStrptr++; else ch = EOF; return(ch); } /*------------------------------------------------------------*/ /* ** next character from terminal input */ PRIVATE int tnextchar() { int ch = cStream->ch; if(ch == EOL || ch == EOF) { cStream->lineno++; tBufptr = treadline(); ch = *tBufptr; if(ch != EOF && ch != EOL) tBufptr++; } else ch = *tBufptr++; return(cStream->ch = ch); } /*--------------------------------------------------------------*/ /* ** returns next character from current input stream ** without advancing file position */ PRIVATE int peekchar(nextch) ifun0 nextch; { int ch; if(nextch == (ifun0)tnextchar) { ch = *tBufptr; } else if(nextch == (ifun0)nextchar) { ch = getc(cFil); ungetc(ch,cFil); } else if(nextch == (ifun0)nextlnchar) { ch = *rBufptr; if(!ch) ch = EOF; } else if(nextch == (ifun0)nextstrchar) { ch = *cStrptr; if(!ch) ch = EOF; } else ch = aERROR; return(ch); } /*--------------------------------------------------------------------*/ /* ** fetch and return the next token from strom ** If an operator is encountered, the corresponding symbol ** is stored in the global variable Curop ** Returns integer aERROR in case of error */ PUBLIC int nexttok(strom,skip) truc *strom; int skip; /* if skip != 0, skips EOL */ { char *buf; int ch, res; ifun0 nextch; nextch = chread(strom); #ifdef SCANLOG if (Slog == NULL) Slog = fopen(slogfile,"w"); slogmess("inside nexttok\n"); #endif nochmal: ch = skipblanks(cStream->ch,nextch); if(isalfa(ch) || ch == '_') { /* symbol input */ buf = SymBuf; *buf++ = ch; while(symbolchar(ch=nextch())) *buf++ = ch; *buf = 0; res = SYMBOLTOK; } else if(isdecdigit(ch)) { StrBuf[0] = ch; res = numinp(nextch,StrBuf,strbufSize); #ifdef SCANLOG slogmess("Curnum[0] = "); slognum((int)Curnum.digits[0]); #endif } else switch(ch) { case '+': nextch(); Curop = plussym; res = PLUSTOK; break; case '-': nextch(); Curop = minussym; res = MINUSTOK; break; case '*': if(nextch() == '*') { nextch(); Curop = powersym; res = POWERTOK; } else { Curop = timessym; res = TIMESTOK; } break; case '/': if(nextch() == '=') { nextch(); Curop = nequalsym; res = NETOK; } else { Curop = divfsym; res = DIVIDETOK; } break; case '(': if(nextch() != '*') res = LPARENTOK; else { nextch(); skipcomment(nextch); goto nochmal; } break; case ')': nextch(); res = RPARENTOK; break; case '[': nextch(); res = LBRACKTOK; break; case ']': nextch(); res = RBRACKTOK; break; case '{': nextch(); res = LBRACETOK; break; case '}': nextch(); res = RBRACETOK; break; case '#': /* ueberlese Kommentar bis zum Ende der Zeile */ while(!isdelim0(nextch())) ; nextch(); goto nochmal; case '=': nextch(); Curop = equalsym; res = EQTOK; break; case '<': ch = nextch(); if(ch == '=') { nextch(); Curop = arilesym; res = LETOK; } else if(ch == '>') { nextch(); Curop = nequalsym; res = NETOK; } else { Curop = ariltsym; res = LTTOK; } break; case '>': if(nextch() == '=') { Curop = arigesym; nextch(); res = GETOK; } else { Curop = arigtsym; res = GTTOK; } break; case '!': res = histinp(nextch,SymBuf); break; case '"': /* string */ nextch(); res = stringinp(nextch,StrBuf,isdelim1); if(res == aERROR) rerror(parserrsym,err_brstr,scratch(StrBuf)); break; case '\'': /* character */ nextch(); res = charinp(nextch,StrBuf); /* unvollstaendig */ if(cStream->ch == '\'') nextch(); if(res == aERROR) { rerror(parserrsym,err_bchar,scratch(StrBuf)); } break; case ':': if(nextch() == '=') { nextch(); Curop = assignsym; res = ASSIGNTOK; } else res = COLONTOK; break; case ';': nextch(); res = SEMICOLTOK; break; case ',': nextch(); res = COMMATOK; break; case '^': nextch(); res = DEREFTOK; break; case '?': ch = nextch(); if(inpsource != TERMINALINP) goto nochmal; else if(ch == '.') nextch(); res = QUESTIONTOK; break; case '.': ch = nextch(); if(ch == '.') { nextch(); res = DOTDOTTOK; break; } ch = skipblanks(ch,nextch); if(isalfa(ch) || ch == '_') res = RECDOTTOK; else res = DOTTOK; break; case '$': buf = (char *)AriScratch; buf[0] = nextch(); res = bstrinp(nextch,buf,2*strbufSize); break; case '\015': /* CR */ ch = peekchar(nextch); if (ch == EOL) nextch(); /* fall through */ case EOL: case FORMFEED: if(skip) { nextch(); goto nochmal; } else res = EOLTOK; break; case ZESC: ch = nextch(); if(ch == '\001') { res = Z1TOK; break; } else goto nochmal; case EOF: res = EOFTOK; break; default: nextch(); res = aERROR; break; } cStream->tok = res; #ifdef SCANLOG slogmess("exiting nexttok, tok =\n"); slognum(res); #endif return(res); } /*------------------------------------------------------------*/ PUBLIC int curtok(strom) truc *strom; { struct stream *strmptr; strmptr = STREAMPTR(strom); return(strmptr->tok); } /*------------------------------------------------------------*/ PUBLIC int fltreadprec() /* used by parser */ { return(curfltprec); } /*-----------------------------------------------------------------*/ PRIVATE int isdelim0(ch) int ch; { if(ch == EOL || ch == FORMFEED || ch == EOF) return(1); else return(0); } /*-----------------------------------------------------------------*/ PRIVATE int isdelim1(ch) int ch; { if(ch == '"' || ch == EOL || ch == EOF) return(1); else return(0); } /*-----------------------------------------------------------------*/ PRIVATE int skipblanks(ch,nextch) int ch; ifun0 nextch; { while(ch == ' ' || ch == '\t') { ch = nextch(); } return(ch); } /*-----------------------------------------------------------------*/ /* ** mode = 0: Loescht blanks vom Anfang des Strings str ** mode != 0: Loescht blanks vom Anfang des Strings und gibt ** dann den String, der aus der naechsten fortlaufenden Serie ** von Nicht-Blanks besteht, zurueck. ** Arbeitet destruktiv auf str !! */ PUBLIC char *trimblanks(str,mode) char *str; int mode; { char *str1; while(*str == ' ' || *str == '\t') str++; if(mode) { str1 = str; while(*str1 > ' ') str1++; *str1 = 0; } return(str); } /*-----------------------------------------------------------------*/ /* ** skip eol token and return the next token */ PUBLIC int skipeoltok(strom) truc *strom; { ifun0 nextch; int tok; nextch = chread(strom); tok = cStream->tok; while(tok == EOLTOK) { nextch(); tok = nexttok(strom,0); } return(tok); } /*-----------------------------------------------------------------*/ /* ** sucht im aktuellen Eingabe-Strom nach dem String "*)" ** Resultat: Erstes Zeichen nach "*)" oder EOF */ PRIVATE int skipcomment(nextch) ifun0 nextch; { int ch = cStream->ch; int ch1; while(ch != EOF) { ch1 = nextch(); if(ch == '*' && ch1 == ')') { ch = nextch(); break; } else { ch = ch1; } } return(ch); } /*-----------------------------------------------------------------*/ /* ** Liest die Symbole !, !!, !!!, !a, !b, !c und schreibt sie in buf ** Das erste ! ist bereits gelesen, aber noch nicht geschrieben. */ PRIVATE int histinp(nextch,buf) ifun0 nextch; char *buf; { int ch; *buf++ = '!'; ch = nextch(); if(ch == '!') { *buf++ = '!'; if(nextch() == '!') { *buf++ = '!'; ch = nextch(); } } else if(ch >= 'a' && ch <= 'c') { *buf++ = ch; ch = nextch(); } if(ch == '.') nextch(); *buf = 0; return(HISTORYTOK); } /*-----------------------------------------------------------------*/ /* ** Speichert String aus strom im Puffer buf */ PRIVATE int stringinp(nextch,buf,delimfun) ifun0 nextch; char *buf; ifun delimfun; { int ch; for(ch=cStream->ch; !delimfun(ch); ch=nextch()) { *buf++ = ch; } *buf = 0; if(ch == '"') { nextch(); return(STRINGTOK); } else return(aERROR); } /*--------------------------------------------------------------------*/ PRIVATE int charinp(nextch,buf) ifun0 nextch; char *buf; { int len = 0; int ch = cStream->ch; if(ch != EOL && ch != EOF) { *buf++ = ch; len++; ch = nextch(); } while(ch != '\'' && ch != EOL && ch != EOF) { *buf++ = ch; len++; ch = nextch(); } *buf = 0; if(len == 1) return(CHARTOK); else return(aERROR); } /*--------------------------------------------------------------------*/ PUBLIC int isalfa(ch) int ch; { if(ch >= 'a' && ch <= 'z') return(1); if(ch >= 'A' && ch <= 'Z') return(1); return(0); } /*------------------------------------------------------------------*/ PUBLIC int isdigalfa(ch) int ch; { return(isalfa(ch) || isdecdigit(ch)); } /*--------------------------------------------------------------------*/ PUBLIC int isdecdigit(ch) int ch; { return(ch >= '0' && ch <= '9'); } /*------------------------------------------------------------------*/ PUBLIC int ishexdigit(ch) int ch; { if(ch >= '0' && ch <= '9') return(1); else if(ch >= 'A' && ch <= 'F') return(1); else if(ch >= 'a' && ch <= 'f') return(1); else return(0); } /*------------------------------------------------------------------*/ PUBLIC int isoctdigit(ch) int ch; { return(ch >= '0' && ch < '8'); } /*------------------------------------------------------------------*/ PUBLIC int isbindigit(ch) int ch; { return(ch == '0' || ch == '1'); } /*-----------------------------------------------------------------*/ PRIVATE int symbolchar(ch) int ch; { if(isalfa(ch) || isdecdigit(ch) || ch == '_') return(1); else return(0); } /*-----------------------------------------------------------------*/ PUBLIC int toupcase(ch) int ch; { if(ch >= 'a' && ch <= 'z') return(ch + ('A' - 'a')); else return(ch); } /*-----------------------------------------------------------------*/ PUBLIC int tolowcase(ch) int ch; { if(ch >= 'A' && ch <= 'Z') return(ch + ('a' - 'A')); else return(ch); } /*-----------------------------------------------------------------*/ /* ** sets global variable curbase and global function checkdig ** to appropriate value ** mode = 0 or mode = 2 */ PRIVATE int isbasemark(ch,mode) int ch, mode; { switch(ch) { case 'x': case 'X': checkdig = ishexdigit; return(curbase = 16); case 'y': case 'Y': checkdig = isbindigit; return(curbase = 2); case 'o': case 'O': checkdig = isoctdigit; return(curbase = 8); default: return(0); } } /*-----------------------------------------------------------------*/ /* ** Stellt fest, ob ch ein exponent marker ist und gibt gegebenenfalls ** zugehoerige float-Laenge zurueck, sonst 0 */ PRIVATE int isexpmark(ch) int ch; { switch(ch) { case 'e': case 'E': return(deffltprec()); case 'f': case 'F': return(FltPrec[0]); case 'd': case 'D': return(FltPrec[1]); case 'l': case 'L': return(FltPrec[2]); /**** extended_float becomes obsolet in future versions ***/ case 'x': case 'X': return(FltPrec[3]); default: return(0); } } /*-----------------------------------------------------------------*/ /* ** entfernt aus Dezimal-String den Dezimalpunkt und Nullen am Ende ** und gibt Dezimalexponenten zurueck ** !!! arbeitet destruktiv auf str !!! */ PRIVATE int normdecstr(str) char *str; { int decexp = 0; char *ptr, *ptr1; ptr = str; while(isdecdigit(*ptr)) ptr++; ptr1 = ptr; if(*ptr == '.') { ptr++; while(isdecdigit(*ptr)) { *ptr1++ = *ptr++; decexp--; } } *ptr1 = 0; while(*--ptr1 == '0' && ptr1 > str) { *ptr1 = 0; decexp++; } return(decexp); } /*------------------------------------------------------------------*/ /* ** Liest aus dem aktuellen Eingabestrom in den Puffer buf ** maximale fortlaufende Sequenz von Ziffern, wobei ** Zifferntrenner (globale Variable digsep) uebergangen werden. ** In buf[0] muss sich das aktuelle Zeichen befinden. ** Es wird die globale Funktion checkdig verwendet. ** Rueckgabewert Anzahl der Ziffern */ PRIVATE int digsequence(nextch,buf,maxlen) ifun0 nextch; char *buf; int maxlen; { int digs = 0; int ch = buf[0]; while(digs < maxlen) { if(checkdig(ch)) { *buf++ = ch; digs++; ch = nextch(); } else if(ch == digsep) { ch = peekchar(nextch); if(checkdig(ch)) ch = nextch(); else if(ch == EOL) { nextch(); ch = nextch(); ch = skipblanks(ch,nextch); if(!checkdig(ch)) break; } else break; } else break; } *buf = ch; return(digs >= maxlen ? -1 : digs); } /*------------------------------------------------------------------*/ /* ** Liest byte_string ein ** In str[0] muss sich das aktuelle Zeichen befinden */ PRIVATE int bstrinp(nextch,str,maxlen) ifun0 nextch; char *str; int maxlen; { int n; checkdig = ishexdigit; numstring = str; n = digsequence(nextch,str,maxlen); if(n < 0) { return(rerror(bstringsym,err_iovfl,voidsym)); } if(n & 1) str[n++] = '0'; str[n] = 0; return(accumbstr(&Curnum)); } /*------------------------------------------------------------------*/ /* ** Liest Integer ein. ** Die erste Ziffer muss sich bereits in str[0] befinden. */ PRIVATE int intinp(nextch,str,maxlen) ifun0 nextch; char *str; int maxlen; { int n; numstring = str; n = digsequence(nextch,str,maxlen); if(n <= 0) { if(n < 0) rerror(voidsym,err_iovfl,voidsym); return(aERROR); } str[n] = 0; accumint(&Curnum); return(INUMTOK); } /*------------------------------------------------------------------*/ PRIVATE int signinp(nextch,str) ifun0 nextch; char *str; { int ch; int sign = 0; ch = str[0]; ch = skipblanks(ch,nextch); if(ch == '+' || ch == '-') { sign = (ch == '+' ? 0 : MINUSBYTE); ch = nextch(); } str[0] = ch = skipblanks(ch,nextch); return(sign); } /*------------------------------------------------------------------*/ /* ** Liest Zahl (integer oder float) ein. ** Die erste Ziffer muss sich bereits in str[0] befinden. ** (Das Vorzeichen muss schon vorher mit eingelesen werden) */ PRIVATE int numinp(nextch,str,maxlen) ifun0 nextch; char *str; int maxlen; { char *str0; int len, len1, prec, ch, ch1; int phase, exdigs; int tok; str0 = str; ch = str[0]; ch1 = peekchar(nextch); if(ch == '0' && isbasemark(ch1,0)) { nextch(); *str = nextch(); return(intinp(nextch,str,maxlen)); } /* #ifdef GF2NINTEGER */ else if(ch == '2' && isbasemark(ch1,2)) { nextch(); *str = nextch(); tok = intinp(nextch,str,maxlen); if(tok == INUMTOK) tok = GF2NTOK; return(tok); } /* #endif GF2NINTEGER */ else if(!isdecdigit(ch)) return(aERROR); curbase = 10; checkdig = isdecdigit; /* before decimal point */ phase = 0; tok = aERROR; numstring = str; len1 = maxlen - (str - str0); len = digsequence(nextch,str,len1); if(len < 0) { goto ovflexit; } str += len; ch = *str; if(ch == '.') { ch1 = peekchar(nextch); if(checkdig(ch1)){ str++; *str = nextch(); phase = '.'; } else { *str = 0; tok = INUMTOK; } } /* else if(!isalfa(ch)) { */ else { *str = 0; tok = INUMTOK; } if(phase == '.') { /* before exponential sign 'e', 'E' */ len1 = maxlen - (str - str0); len = digsequence(nextch,str,len1); if(len < 0) { goto ovflexit; } str += len; ch = *str; if((prec = isexpmark(ch))) { *str++ = 0; ch = nextch(); phase = 'E'; } else if(!isalfa(ch)) { *str = 0; prec = deffltprec(); expstring = NULL; tok = FLOATTOK; } } if(phase == 'E') { /* inside exponent */ if(ch == '+') { expsign = 0; ch = nextch(); } else if(ch == '-') { expsign = MINUSBYTE; ch = nextch(); } else expsign = 0; expstring = str; exdigs = 0; while(isdecdigit(ch)) { *str++ = ch; exdigs++; ch = nextch(); } if(exdigs) { *str = 0; tok = FLOATTOK; } } if(tok == INUMTOK) tok = accumint(&Curnum); else if(tok == FLOATTOK) { curfltprec = prec; tok = accumfloat(&Curnum); } return(tok); ovflexit: return(rerror(voidsym,err_iovfl,voidsym)); } /*-----------------------------------------------------------------*/ /* ** Benuetzt die globalen Variablen numstring, curbase, um den ** dadurch gegebenen (vorzeichenlosen) Integer in *numptr abzulegen ** Fuer numptr->digits wird AriBuf benuetzt, ** numptr->expo wird gleich 0 gesetzt ** (so dass numptr auch als float interpretiert werden kann) */ PRIVATE int accumint(numptr) numdata *numptr; { int n; word2 *x, *hilf; x = AriScratch; hilf = x + aribufSize; switch(curbase) { case 10: n = str2big(numstring,x,hilf); break; case 16: n = xstr2big(numstring,x); break; case 8: n = ostr2big(numstring,x); break; case 2: n = bstr2big(numstring,x); break; default: n = 0; } cpyarr(x,n,AriBuf); numptr->len = n; numptr->digits = AriBuf; numptr->sign = 0; numptr->expo = 0; return(INUMTOK); } /*-----------------------------------------------------------------*/ PRIVATE int accumbstr(numptr) numdata *numptr; { byte *ptr; int ch; unsigned u, v; unsigned len = 0; ptr = (byte *)AriBuf; while((ch = *numstring++)) { u = digval(ch); v = digval(*numstring++); *ptr++ = (u << 4) + v; len++; } numptr->digits = AriBuf; numptr->len = len; return(BSTRINGTOK); } /*-----------------------------------------------------------------*/ /* ** Benuetzt die globalen Variablen ** numstring, expstring, expsign ** um die dadurch gegebene Float-Zahl in *numptr abzulegen ** Fuer numptr->digits wird AriBuf benuetzt. */ PRIVATE int accumfloat(numptr) numdata *numptr; { long decexp; word4 u; int prec = curfltprec + 2; int len; word2 *x, *hilf; x = AriScratch; hilf = x + aribufSize; len = (expstring ? str2big(expstring,x,hilf) : 0); if(len > 2 || (u = big2long(x,len)) > maxdecex) return(rerror(parserrsym,err_ovfl,voidsym)); decexp = u; if(expsign) decexp = -decexp; decexp += normdecstr(numstring); len = str2big(numstring,x,hilf); cpyarr(x,len,AriBuf); numptr->len = len; numptr->digits = AriBuf; numptr->expo = decexp; numptr->sign = 0; flodec2bin(prec,numptr,hilf); return(FLOATTOK); } /*----------------------------------------------------------*/ PRIVATE truc Satoi() { return(Snumval(atoisym)); } /*----------------------------------------------------------*/ PRIVATE truc Satof() { return(Snumval(atofsym)); } /*----------------------------------------------------------*/ PRIVATE truc Snumval(symb) truc symb; { truc obj; char *str; unsigned len; int argn, count, tok; obj = eval(ARG1PTR(evalStkPtr)); if(Tflag(obj) != fSTRING) { error(symb,err_str,obj); return(brkerr()); } len = STRlen(obj); if(len >= strbufSize-3) { error(symb,err_2long,mkfixnum(len)); return(brkerr()); } str = STRING(obj); tok = numval(str,&count); if(symb == atoisym) { if(tok == INUMTOK) obj = mkint(Curnum.sign,Curnum.digits,Curnum.len); else { count = 0; obj = zero; } } else { /* symb == atofsym */ if(tok != FLOATTOK) curfltprec = deffltprec(); if(tok != FLOATTOK && tok != INUMTOK) { count = 0; obj = fltzero(curfltprec); } else { obj = mkfloat(curfltprec,&Curnum); } } argn = *ARGCOUNTPTR(evalStkPtr); if(argn == 2) { Lvalassign(ARGNPTR(evalStkPtr,2),mkfixnum(count)); } return(obj); } /*----------------------------------------------------------*/ PRIVATE int numval(str,pcount) char *str; int *pcount; { char *buf; ifun0 nextch; int sign; int n, count, tok; buf = StrBuf; /* global variable, == AriBuf */ n = strncopy(buf,str,strbufSize-3); buf[n] = EOL; buf[n+1] = EOL; buf[n+2] = 0; nextch = readfrom(buf); buf[0] = nextch(); sign = signinp(nextch,buf); tok = numinp(nextch,buf,strbufSize); Curnum.sign = sign; if(tok == aERROR) count = 0; else { count = cStrptr - buf; count--; } *pcount = count; return(tok); } /*----------------------------------------------------------*/ /* ** reading one item (of data type given by *ptr) in function readln */ PRIVATE int readlnitem(nextch,ptr) ifun0 nextch; truc *ptr; { int ch, typ, flg, tok, tok1, sign, maxlen; char *cptr; truc obj; truc *vptr, *varptr; ch = rChar; WORKpush(*ptr); typ = Lvaladdr(workStkPtr,&varptr); if(typ == vUNBOUND) { if(isdecdigit(ch)) tok = INUMTOK; else tok = STRINGTOK; } else if(typ == vBOUND) { flg = *FLAGPTR(varptr); if(flg == fCHARACTER) tok = CHARTOK; else if(flg == fSTRING) tok = STRINGTOK; else if(flg == fFIXNUM || flg == fBIGNUM) tok = INUMTOK; else if(flg >= fFLTOBJ) tok = FLOATTOK; else tok = aERROR; } else if(typ == vARRELE) { ARGpush(varptr[1]); *argStkPtr = eval(argStkPtr); flg = *FLAGPTR(argStkPtr); if(flg == fSTRING) tok = CHARTOK; else if(flg == fVECTOR) { vptr = VECTORPTR(argStkPtr); flg = *FLAGPTR(vptr); if(flg == fCHARACTER) tok = CHARTOK; else if(flg == fSTRING) tok = STRINGTOK; else if(flg == fFIXNUM || flg == fBIGNUM) tok = INUMTOK; else if(flg >= fFLTOBJ) tok = FLOATTOK; else tok = aERROR; } else { tok = aERROR; } ARGpop(); } else if(typ == vRECFIELD) { error(rec_sym,err_imp,voidsym); tok = aERROR; } else { tok = aERROR; } if(ch == EOL && tok != STRINGTOK) { tok = aERROR; } if(tok == aERROR) { goto ausgang; } if(tok == CHARTOK) { obj = mkchar(ch); nextch(); } else if(tok == STRINGTOK) { maxlen = strbufSize; cptr = StrBuf; while(ch != EOL && ch != EOF && --maxlen > 0) { *cptr++ = ch; ch = nextch(); } *cptr = 0; obj = mkstr(StrBuf); } else { StrBuf[0] = ch; sign = signinp(nextch,StrBuf); tok1 = numinp(nextch,StrBuf,strbufSize); Curnum.sign = sign; if(tok1 == aERROR || tok1 > tok) { tok = aERROR; goto ausgang; } if(tok == FLOATTOK) obj = mkfloat(curfltprec,&Curnum); else obj = mkint(Curnum.sign,Curnum.digits,Curnum.len); } Lvalassign(workStkPtr,obj); ausgang: WORKpop(); return(tok); } /*----------------------------------------------------------*/ PRIVATE truc Sreadln() { char buf[IOBUFSIZE+2]; int ch, i, k, count, argn, typ, ret; truc *ptr; truc strom; ifun0 nextch; k = 1; strom = tstdin; argn = *ARGCOUNTPTR(evalStkPtr); if(argn >= 1) { typ = Lvaladdr(ARG1PTR(evalStkPtr),&ptr); if(typ == vBOUND && *FLAGPTR(ptr) == fSTREAM) { if(!isinpfile(ptr,aTEXT)) { error(readlnsym,err_tinp,voidsym); return(brkerr()); } else { strom = *ptr; k = 2; } } } nextch = lnread(&strom,buf); ch = nextch(); for(count=0,i=k; (i<=argn)&&(ch != EOF); i++,count++) { ret = readlnitem(nextch,ARGNPTR(evalStkPtr,i)); if(ret == aERROR) { break; } ch = rChar; } if ((ch == EOF) && (count == 0)) count = -1; return(mksfixnum(count)); } /*----------------------------------------------------------*/ PUBLIC int rerror(sym1,mess,sym2) truc sym1, sym2; char *mess; { char *st = "terminal input"; char *sf = "loaded file"; wtruc src; if(inpsource == STRINGINPUT) strcopy(OutBuf,"error while reading from string"); else if(inpsource == READLNINPUT) strcopy(OutBuf,"error in function readln"); else { if(inpsource == TERMINALINP) src = strcast(st); else /* FILEINPUT */ src = strcast(sf); s2form(OutBuf, "error in line <= ~D of ~A",intcast(cStream->lineno),src); } fprintline(tstderr,OutBuf); return(error(sym1,mess,sym2)); } /********************************************************************/ aribas165b/src/storage.c0000644000076600000240000006311514660570650014204 0ustar ottostaff/****************************************************************/ /* file storage.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** storage.c ** storage of symbols ** ** date of last change ** 1995-04-08: fixed bug with hugefloat ** 1997-04-13: newreflsym(), neworg (newintsym) ** 2000-12-28: removed some debugging code ** 2002-04-19: mkgf2n, mk0gf2n ** 2004-11-29: changed mkcopy, mkcopy0 */ #include "common.h" PUBLIC void inistore (void); PUBLIC truc *nextsymptr (int i); PUBLIC truc symbobj (truc *ptr); PUBLIC int lookupsym (char *name, truc *pobj); PUBLIC truc mksym (char *name, int *sflgptr); PUBLIC truc scratch (char *name); PUBLIC truc newselfsym (char *name, int flg); PUBLIC truc newreflsym (char *name, int flg); PUBLIC truc newintsym (char *name, int flg, wtruc bind); PUBLIC int tokenvalue (truc op); PUBLIC truc newsym (char *name, int flg, truc bind); PUBLIC truc newsymsig (char *name, int flg, wtruc bind, int sig); PUBLIC truc new0symsig (char *name, int flg, wtruc bind, int sig); PUBLIC truc mkcopy (truc *x); PUBLIC truc mkcopy0 (truc *x); PUBLIC truc mkarrcopy (truc *x); PUBLIC truc mkinum (long n); PUBLIC truc mkarr2 (unsigned w0, unsigned w1); PUBLIC truc mklocsym (int flg, unsigned u); PUBLIC truc mkfixnum (unsigned n); PUBLIC truc mksfixnum (int n); PUBLIC truc mkint (int sign, word2 *arr, int len); PUBLIC truc mkgf2n (word2 *arr, int len); PUBLIC truc mk0gf2n (word2 *arr, int len); PUBLIC truc mkfloat (int prec, numdata *nptr); PUBLIC truc fltzero (int prec); PUBLIC truc mk0float (numdata *nptr); PUBLIC truc mkchar (int ch); PUBLIC truc mkbstr (byte *arr, unsigned len); PUBLIC truc mkstr (char *str); PUBLIC truc mkstr0 (unsigned len); PUBLIC truc mkbstr0 (unsigned len); PUBLIC truc mknullstr (void); PUBLIC truc mknullbstr (void); PUBLIC truc mkvect0 (unsigned len); PUBLIC truc mkrecord (int flg, truc *ptr, unsigned len); PUBLIC truc mkstack (void); PUBLIC truc mkstream (FILE *file, int mode); PUBLIC truc mk0stream (FILE *file, int mode); PUBLIC truc mk0fun (truc op); PUBLIC truc mkpair (int flg, truc sym1, truc sym2); PUBLIC truc mkunode (truc op); PUBLIC truc mkbnode (truc op); PUBLIC truc mkspecnode (truc fun, truc *argptr, int k); PUBLIC truc mkfunode (truc fun, int n); PUBLIC truc mkfundef (int argc, int argoptc, int varc); PUBLIC truc mkntuple (int flg, truc *arr, int n); PUBLIC truc mkcompnode (int flg, int n); /*----------------------------------------------------------------*/ PRIVATE int hash (char *name); PRIVATE truc *mksymaux (int flg, char *name, int mode); PRIVATE truc *findsym (char *name, int mode); PRIVATE truc mkstraux (int flg, char *str, unsigned len, int mode); PRIVATE truc mkstraux0 (int flg, unsigned len, int mode); PRIVATE void streamaux (FILE *file, int mode, struct stream *ptr); PRIVATE truc scratchsym; /*----------------------------------------------------------------*/ PUBLIC void inistore() { scratchsym = newselfsym("",sINTERNAL); } /*----------------------------------------------------------------*/ PRIVATE int hash(name) char *name; { register unsigned long h = 0; register int ch; int i = 10; while((ch = *name++)) { h += ch; if(--i >= 0) h <<= 3; } return(h % hashtabSize); } /* -----------------------------------------------------------*/ PRIVATE truc *mksymaux(flg,name,mode) int flg; char *name; int mode; /* mode != 0: allocate new space for name */ { truc *ptr; char *str; size_t wo; wo = new0(SIZEOFSYMBOL); ptr = Symbol + wo; *FLAGPTR(ptr) = flg; *SEGPTR(ptr) = 0; *OFFSPTR(ptr) = (word2)wo; if(mode) { str = stringalloc(strlen(name) + 1); ((struct symbol *)ptr)->name = str; strcopy(str,name); } else ((struct symbol *)ptr)->name = name; ((struct symbol *)ptr)->bind.t = zero; /* zur Sicherheit */ ((struct symbol *)ptr)->cc.xx = 0; return(ptr); } /*-------------------------------------------------------------------*/ /* ** Zum Durchlaufen der Symboltabelle. ** Anfang mit Argument 0 ** used during garbage collection */ PUBLIC truc *nextsymptr(i) int i; { static truc *ptr = NULL; static int index = -1; truc *ptr1; if(i == 0) { ptr = NULL; index = -1; } while(ptr == NULL) { if(++index >= hashtabSize) { index = -1; return(NULL); } ptr = Symtab[index]; } ptr1 = ptr; ptr = ((struct symbol *)ptr)->link; return(ptr1); } /*-------------------------------------------------------------------*/ /* ** constructs symbol truc associated to symbol at place ptr */ PUBLIC truc symbobj(ptr) truc *ptr; { variant v; v.xx = *ptr; v.pp.b0 = fSYMBOL; return(v.xx); } /*-------------------------------------------------------------------*/ /* ** find resp. make a symbol object */ PRIVATE truc *findsym(name,mode) char *name; int mode; /* mode == 0: use string space of name */ { trucptr *pptr; truc *ptr, *ptr1; int cmp; pptr = Symtab + hash(name); while((ptr = *pptr) != NULL) { cmp = strcmp(name,((struct symbol *)ptr)->name); if(cmp == 0) /* found */ return(ptr); if(cmp < 0) /* not present */ break; pptr = (trucptr *)&(((struct symbol *)ptr)->link); } *pptr = ptr1 = mksymaux(sUNBOUND,name,mode); /* insert */ ((struct symbol *)ptr1)->link = ptr; return(ptr1); } /*---------------------------------------------------------------------*/ PUBLIC int lookupsym(name,pobj) char *name; truc *pobj; { truc *ptr; int cmp, sflg; ptr = Symtab[hash(name)]; while(ptr != NULL) { cmp = strcmp(name,((struct symbol *)ptr)->name); if(cmp == 0) { /* found */ sflg = *FLAGPTR(ptr); *pobj = symbobj(ptr); return(sflg); } if(cmp < 0) /* not present */ break; ptr = ((struct symbol *)ptr)->link; } return(aERROR); /* not found */ } /*---------------------------------------------------------------------*/ PUBLIC truc mksym(name,sflgptr) char *name; int *sflgptr; { variant v; v.xx = *findsym(name,1); *sflgptr = v.pp.b0; v.pp.b0 = fSYMBOL; return(v.xx); } /*---------------------------------------------------------------------*/ /* ** make a temporary symbol with given name */ PUBLIC truc scratch(name) char *name; { SYMname(scratchsym) = name; return(scratchsym); } /*----------------------------------------------------------------------*/ /* ** make internal symbol, not in hash table, ** bound to itself */ PUBLIC truc newselfsym(name,flg) char *name; int flg; { truc obj; obj = newintsym(name,flg,(wtruc)0); SYMbind(obj) = obj; return(obj); } /*----------------------------------------------------------------------*/ /* ** make internal symbol, not in hash table, ** with given name, flag, binding */ PUBLIC truc newintsym(name,flg,bind) char *name; int flg; wtruc bind; { truc *ptr; variant v; size_t wo; wo = new0(SIZEOFINTSYMBOL); ptr = Symbol + wo; *FLAGPTR(ptr) = flg; *SEGPTR(ptr) = 0; *OFFSPTR(ptr) = (word2)wo; ((struct intsymbol *)ptr)->name = name; ((struct intsymbol *)ptr)->bind.w = bind; v.xx = *ptr; v.pp.b0 = fSYMBOL; return(v.xx); } /*----------------------------------------------------------------------*/ /* ** make internal symbol, not in hash table, ** with given name, flag, binding and signature */ PUBLIC truc new0symsig(name,flg,bind,sig) char *name; int flg; wtruc bind; int sig; { truc *ptr; variant v; ptr = mksymaux(flg,name,0); v.xx = *ptr; v.pp.b0 = fSYMBOL; ((struct symbol *)ptr)-> bind.w = bind; ((struct symbol *)ptr)->cc.yy.ww = sig; return(v.xx); } /*---------------------------------------------------------------------*/ /* ** returns token associated to symbols representing infix operators */ PUBLIC int tokenvalue(op) truc op; { variant v; v.xx = SYMcc(op); return(v.pp.ww); } /*---------------------------------------------------------------------*/ /* ** make a new symbol object (in hash table) ** with given name, flag and binding */ PUBLIC truc newsym(name,flg,bind) char *name; int flg; truc bind; { variant v; truc *ptr; ptr = findsym(name,0); *FLAGPTR(ptr) = flg; ((struct symbol *)ptr)->bind.t = bind; v.xx = *ptr; v.pp.b0 = fSYMBOL; return(v.xx); } /*---------------------------------------------------------------------*/ /* ** make a new symbol object (in hash table) ** with given name and flag, bound to itself */ PUBLIC truc newreflsym(name,flg) char *name; int flg; { variant v; truc *ptr; ptr = findsym(name,0); *FLAGPTR(ptr) = flg; v.xx = *ptr; v.pp.b0 = fSYMBOL; ((struct symbol *)ptr)->bind.t = v.xx; return(v.xx); } /*---------------------------------------------------------------------*/ /* ** make a new symbol object with given name, flag, binding and signature */ PUBLIC truc newsymsig(name,flg,bind,sig) char *name; int flg; wtruc bind; int sig; { variant v; truc *ptr; ptr = findsym(name,0); *FLAGPTR(ptr) = flg; ((struct symbol *)ptr)->bind.w = bind; ((struct symbol *)ptr)->cc.yy.ww = sig; v.xx = *ptr; v.pp.b0 = fSYMBOL; return(v.xx); } /*--------------------------------------------------------*/ /* ** Stellt Kopie eines Objekts *x her (top-level) ** Es wird vorausgesetzt, dass x bei gc geschuetzt ist */ PUBLIC truc mkcopy0(x) truc *x; { truc *ptr; truc obj; unsigned int len; int flg = *FLAGPTR(x); if((flg & FIXMASK) || (!*SEGPTR(x))) return(*x); len = obj4size(flg,TAddress(x)); obj = newobj(flg,len,&ptr); cpy4arr(TAddress(x),len,ptr); return(obj); } /*--------------------------------------------------------*/ /* ** Stellt Kopie eines Objekts *x her (top-level) ** Es wird vorausgesetzt, dass x bei gc geschuetzt ist ** ??? same as mkcopy0 ??? */ PUBLIC truc mkcopy(x) truc *x; { truc *ptr; truc obj; unsigned int len; int flg = *FLAGPTR(x); if((flg & FIXMASK)) return(*x); len = obj4size(flg,TAddress(x)); obj = newobj(flg,len,&ptr); cpy4arr(TAddress(x),len,ptr); return(obj); } /*--------------------------------------------------------*/ /* ** Stellt Kopie eines Objekts *x her (Array beliebigen Ranges oder record) ** Es wird vorausgesetzt, dass x bei gc geschuetzt ist */ PUBLIC truc mkarrcopy(x) truc *x; { truc *ptr; truc obj; unsigned int i, len; int flg = *FLAGPTR(x); if(flg & FIXMASK) return(*x); len = obj4size(flg,TAddress(x)); obj = newobj(flg,len,&ptr); cpy4arr(TAddress(x),len,ptr); if(flg < fRECORD || flg > fVECTOR || len < 2) return(obj); /* now recursively copy components of vector or record */ WORKpush(obj); ARGpush(zero); ptr++; for(i=1; i= fRECORD && flg <= fVECTLIKE1) { *argStkPtr = *ptr; obj = mkarrcopy(argStkPtr); ptr = TAddress(workStkPtr)+i; *ptr++ = obj; } else ptr++; } ARGpop(); return(WORKretr()); } /*--------------------------------------------------------*/ /* ** make an intobj from long */ PUBLIC truc mkinum(n) long n; { struct bigcell *ptr; truc obj; variant v; int sign; sign = (n < 0 ? MINUSBYTE : 0); if(sign) n = -n; if(n < 0x10000) { v.pp.b0 = fFIXNUM; v.pp.b1 = sign; v.pp.ww = n; return(v.xx); } else { obj = newobj(fBIGNUM,SIZEOFBIG(2),(trucptr *)&ptr); ptr->flag = fBIGNUM; ptr->signum = sign; ptr->len = 2; ptr->digi0 = n & 0xFFFF; ptr->digi1 = n >> 16; return(obj); } } /*--------------------------------------------------------------*/ PUBLIC truc mkarr2(w0,w1) unsigned w0, w1; { variant v; v.yy.w0 = w0; v.yy.ww = w1; return(v.xx); } /*--------------------------------------------------------------*/ PUBLIC truc mklocsym(flg,u) int flg; unsigned u; { variant v; v.pp.b0 = flg; v.pp.b1 = 0; v.pp.ww = u; return(v.xx); } /*--------------------------------------------------------------*/ /* ** stellt aus der Zahl n >= 0 ein fixnum her */ PUBLIC truc mkfixnum(n) unsigned n; { variant v; v.pp.b0 = fFIXNUM; v.pp.b1 = 0; v.pp.ww = n; return(v.xx); } /*--------------------------------------------------------------*/ /* ** stellt aus der Zahl n ein fixnum her; ** Vorzeichen von n wird beruecksichtigt */ PUBLIC truc mksfixnum(n) int n; { variant v; v.pp.b0 = fFIXNUM; if(n < 0) { v.pp.b1 = MINUSBYTE; n = -n; } else v.pp.b1 = 0; v.pp.ww = n; return(v.xx); } /*--------------------------------------------------------------*/ /* ** make intobj from big-array */ PUBLIC truc mkint(sign,arr,len) int sign; word2 *arr; int len; { struct bigcell *big; variant v; truc obj; if(len <= 1) { v.pp.b0 = fFIXNUM; if(!len) { v.pp.b1 = 0; v.pp.ww = 0; } else { v.pp.b1 = sign; v.pp.ww = *arr; } return(v.xx); } /* else if(len >= 2) */ obj = newobj(fBIGNUM,SIZEOFBIG(len),(trucptr *)&big); big->flag = fBIGNUM; big->signum = sign; big->len = len; cpyarr(arr,len,&(big->digi0)); return(obj); } /*--------------------------------------------------------------*/ /* ** make gf2nint from (arr,len) */ PUBLIC truc mkgf2n(arr,len) word2 *arr; int len; { struct bigcell *big; truc obj; if(len <= 1) { if (!len) return gf2nzero; else if (arr[0] == 1) return gf2none; /* else fall through */ } obj = newobj(fGF2NINT,SIZEOFBIG(len),(trucptr *)&big); big->flag = fGF2NINT; big->signum = 0; big->len = len; cpyarr(arr,len,&(big->digi0)); return(obj); } /*--------------------------------------------------------------*/ /* ** make gf2nint which is not moved during garbage collection */ PUBLIC truc mk0gf2n(arr,len) word2 *arr; int len; { struct bigcell *big; truc obj; obj = new0obj(fGF2NINT,SIZEOFBIG(len),(trucptr *)&big); big->flag = fGF2NINT; big->signum = 0; big->len = len; cpyarr(arr,len,&(big->digi0)); return(obj); } /*--------------------------------------------------------------*/ PUBLIC truc mkfloat(prec,nptr) int prec; /* must be one of FltPrec[k] */ numdata *nptr; { struct floatcell *fl; truc obj; long ex; unsigned hugelow; int hugeflg = 0; int n, flg, pcode; n = normfloat(prec,nptr); if(n == 0) return(fltzero(prec)); ex = nptr->expo; pcode = fltpreccode(prec); flg = fFLTOBJ + (pcode<<1); if(ex >= 0x8000 || -ex > 0x8000) { hugeflg = 1; flg |= HUGEFLTBIT; hugelow = ex & 0x7F; ex >>= 7; } obj = newobj(flg,SIZEOFFLOAT(prec),(trucptr *)&fl); fl->flag = flg; fl->signum = (nptr->sign ? FSIGNBIT : 0); if(hugeflg) fl->signum |= hugelow; fl->expo = ex; cpyarr(nptr->digits,prec,&(fl->digi0)); return(obj); } /*--------------------------------------------------------------*/ PUBLIC truc fltzero(prec) int prec; /* must be one of FltPrec[k] */ { variant v; int pcode; pcode = fltpreccode(prec); v.pp.b0 = fFLTOBJ + (pcode<<1) + FLTZEROBIT; v.pp.b1 = 0; v.pp.ww = 0; return(v.xx); } /*--------------------------------------------------------------*/ /* ** make a float which is not moved during garbage collection */ PUBLIC truc mk0float(nptr) numdata *nptr; /* nptr wird als normalisiert und nicht huge vorausgesetzt */ { struct floatcell *fl; truc obj; int prec, flg, pcode; prec = nptr->len; pcode = fltpreccode(prec); flg = fFLTOBJ + (pcode<<1); obj = new0obj(flg,SIZEOFFLOAT(prec),(trucptr *)&fl); fl->flag = flg; fl->signum = (nptr->sign ? FSIGNBIT : 0); fl->expo = nptr->expo; cpyarr(nptr->digits,prec,&(fl->digi0)); return(obj); } /*--------------------------------------------------------------*/ /* ** make a character object */ PUBLIC truc mkchar(n) int n; { variant v; v.pp.b0 = fCHARACTER; v.pp.b1 = 0; v.pp.ww = (n & 0x00FF); return(v.xx); } /*--------------------------------------------------------------*/ /* ** make a byte_string object for byte array (arr,len) */ PUBLIC truc mkbstr(arr,len) byte *arr; unsigned int len; { return(mkstraux(fBYTESTRING,(char *)arr,len,1)); } /*--------------------------------------------------------------*/ /* ** make a string object for string str */ PUBLIC truc mkstr(str) char *str; { unsigned len = strlen(str); return(mkstraux(fSTRING,str,len,1)); } /*---------------------------------------------------------*/ /* ** make a string object for unknown string of length len */ PUBLIC truc mkstr0(len) unsigned len; { return(mkstraux0(fSTRING,len,1)); } /*---------------------------------------------------------*/ /* ** make a bytestring object for unknown string of length len */ PUBLIC truc mkbstr0(len) unsigned len; { return(mkstraux0(fBYTESTRING,len,1)); } /*---------------------------------------------------------*/ /* ** make a nullstring, not moved during gc */ PUBLIC truc mknullstr() { return(mkstraux0(fSTRING,0,0)); } /*---------------------------------------------------------*/ /* ** make a nullbytestring, not moved during gc */ PUBLIC truc mknullbstr() { return(mkstraux0(fBYTESTRING,0,0)); } /*---------------------------------------------------------*/ PRIVATE truc mkstraux(flg,str,len,mode) int flg; /* fSTRING or fBYTESTRING */ char *str; unsigned len; int mode; /* mode = 0: string not moved during gc */ { unsigned k; struct strcell *ptr; truc obj; char *cpt; if(mode) obj = newobj(flg,SIZEOFSTRING(len),(trucptr *)&ptr); else obj = new0obj(flg,SIZEOFSTRING(len),(trucptr *)&ptr); ptr->flag = fSTRING; ptr->flg2 = 0; ptr->len = len; cpt = (char *)&(ptr->ch0); for(k=0; kflag = fSTRING; ptr->flg2 = 0; ptr->len = len; cpt = (char *)&(ptr->ch0); for(k=0; k<=len; k++) *cpt++ = 0; return(obj); } /*---------------------------------------------------------*/ /* ** make a vector object for vector of length len ** initialized with zeroes */ PUBLIC truc mkvect0(len) unsigned int len; { struct vector *ptr; truc *vec; truc obj; unsigned int k; k = SIZEOFVECTOR(len); /* k is positive */ obj = newobj(fVECTOR,k,(trucptr *)&ptr); ptr->flag = fVECTOR; ptr->flg2 = 0; ptr->len = len; vec = (truc *)&(ptr->ele0); while(--k) *vec++ = zero; return(obj); } /*-------------------------------------------------------------*/ PUBLIC truc mkrecord(flg,ptr,len) int flg; /* fRECORD or fPOINTER */ truc *ptr; unsigned len; { struct record *rptr; truc obj; unsigned k; k = SIZEOFRECORD(len); obj = newobj(flg,k,(trucptr *)&rptr); rptr->flag = flg; rptr->flg2 = 0; rptr->len = len; cpy4arr(ptr,len+1,(truc *)&(rptr->recdef)); return(obj); } /*-------------------------------------------------------------*/ PUBLIC truc mkstack() { struct stack *ptr; truc obj; obj = newobj(fSTACK,SIZEOFSTACK,(trucptr *)&ptr); ptr->flag = fSTACK; ptr->line = 0; ptr->pageno = 0; ptr->type = zero; ptr->page = nullsym; return(obj); } /*-------------------------------------------------------------*/ PUBLIC truc mkstream(file,mode) FILE *file; int mode; { struct stream *ptr; truc strm = newobj(fSTREAM,SIZEOFSTREAM,(trucptr *)&ptr); streamaux(file,mode,ptr); return(strm); } /* ---------------------------------------------------------- */ PRIVATE void streamaux(file,mode,ptr) FILE *file; int mode; struct stream *ptr; { ptr->flag = fSTREAM; ptr->mode = mode; ptr->pos = 0; ptr->lineno = 1; ptr->ch = EOL; ptr->tok = EOLTOK; ptr->file = file; } /* ---------------------------------------------------------- */ /* ** make a stream which is not moved during garbage collection */ PUBLIC truc mk0stream(file,mode) FILE *file; int mode; { struct stream *ptr; truc strm = new0obj(fSTREAM,SIZEOFSTREAM,(trucptr *)&ptr); streamaux(file,mode,ptr); return(strm); } /*--------------------------------------------------------------*/ /* ** make function object without arguments */ PUBLIC truc mk0fun(op) truc op; { variant v; int sflg; sflg = Symflag(op); if(sflg == sFBINARY || sflg == sSBINARY) { v.xx = op; v.pp.b0 = fSPECIAL0; return(v.xx); } else return(mkfunode(op,0)); } /*--------------------------------------------------------------*/ PUBLIC truc mkpair(flg,sym1,sym2) int flg; truc sym1, sym2; { struct opnode *node; truc obj; obj = newobj(flg,SIZEOFOPNODE(1),(trucptr *)&node); node->op = sym1; node->arg0 = sym2; return(obj); } /*--------------------------------------------------------------*/ /* ** make unary opnode with arg from ParseStack */ PUBLIC truc mkunode(op) truc op; { struct opnode *node; truc obj; int flg, sflg; sflg = Symflag(op); if(sflg == sSBINARY) flg = fSPECIAL1; else if(sflg == sFBINARY) flg = fBUILTIN1; else return(mkfunode(op,1)); obj = newobj(flg,SIZEOFOPNODE(1),(trucptr *)&node); node->op = op; node->arg0 = *argStkPtr; return(obj); } /*--------------------------------------------------------------*/ /* ** make binary opnode with arg0 and arg1 from ParseStack */ PUBLIC truc mkbnode(op) truc op; { struct opnode *node; truc obj; int flg, sflg; sflg = Symflag(op); if(sflg == sSBINARY) flg = fSPECIAL2; else if(sflg == sFBINARY) flg = fBUILTIN2; else return(mkfunode(op,2)); obj = newobj(flg,SIZEOFOPNODE(2),(trucptr *)&node); node->op = op; node->arg0 = argStkPtr[-1]; node->arg1 = argStkPtr[0]; return(obj); } /*--------------------------------------------------------------*/ PUBLIC truc mkspecnode(fun,argptr,k) truc fun; truc *argptr; int k; /* k == 1 or k == 2 */ { struct opnode *node; int flg; truc obj; flg = (k == 1 ? fSPECIAL1 : fSPECIAL2); obj = newobj(flg,SIZEOFOPNODE(k),(trucptr *)&node); node->op = fun; node->arg0 = argptr[0]; if(k == 2) node->arg1 = argptr[1]; return(obj); } /*--------------------------------------------------------------*/ PUBLIC truc mkfunode(fun,n) truc fun; int n; { struct funode *node; truc obj; truc *ptr; int flg, sflg; sflg = Symflag(fun); if(sflg == sFBINARY) { flg = fBUILTINn; } else if(sflg == sSBINARY) { flg = fSPECIALn; } else flg = fFUNCALL; obj = newobj(flg,SIZEOFFUNODE(n),(trucptr *)&node); node->op = fun; node->argno = mkfixnum(n); ptr = (truc *)&(node->arg1); while(--n >= 0) { *ptr++ = argStkPtr[-n]; } return(obj); } /*--------------------------------------------------------------*/ PUBLIC truc mkfundef(argc,argoptc,varc) int argc, argoptc, varc; { struct fundef *node; truc obj; obj = newobj(fFUNDEF,SIZEOFFUNDEF,(trucptr *)&node); node->flag = fFUNDEF; node->flg2 = argoptc; node->argc = argc; node->varno = mkfixnum(varc); node->body = argStkPtr[0]; node->parms = argStkPtr[-2]; node->vars = argStkPtr[-1]; return(obj); } /*--------------------------------------------------------------*/ /* ** make node with n expressions from array arr */ PUBLIC truc mkntuple(flg,arr,n) int flg, n; truc *arr; { truc *node; truc obj; variant v; obj = newobj(flg,SIZEOFTUPLE(n),&node); v.pp.b0 = flg; v.pp.b1 = 0; v.pp.ww = n; *node++ = v.xx; cpy4arr(arr,n,node); return(obj); } /*--------------------------------------------------------------*/ /* ** make node with n statements from ParseStack in reverse order */ PUBLIC truc mkcompnode(flg,n) int flg, n; { truc *node; truc obj; variant v; int i; obj = newobj(flg,SIZEOFCOMP(n),&node); v.pp.b0 = flg; v.pp.b1 = 0; v.pp.ww = n; *node++ = v.xx; for(i=0; icc.yy.ww]; k = (byte)ss[0]; if(k != MAXBYTE && n+1 == k) ret = NARGS_OK; else if(k == MAXBYTE) { k1 = (byte)ss[1]; k2 = (byte)ss[2]; if(n+1 < k1 || (k2 != MAXBYTE && n+1 > k2)) ret = NARGS_FALSE; else ret = NARGS_VAR; } else ret = NARGS_FALSE; } else { /* user defined function */ ret = NARGS_OK; /* vorlaeufig */ } return(ret); } /**********************************************************************/ aribas165b/src/sysdep.c0000644000076600000240000001711114660570651014043 0ustar ottostaff/****************************************************************/ /* file sysdep.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2024 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** sysdep.c ** sytemabhaengige Funktionen ** fuer stack check, timer, random seed ** sowie appl_init fuer ATARI-Version ** ** date of last change ** 1994-09-15 ** 1996-10-22 SysDUM ** 2002-04-27 datetime */ #include "common.h" #ifdef MsDOS #include #endif #ifdef ATARIST #include #endif #ifdef DOSorUNiX #include #endif #ifdef DOSorTOS #include #endif #ifdef MsWIN32 #include #endif /* ** if you have (under UNIX) compiling problems with the system ** dependent functions, define the symbol SysDUM or TimeDUM ** Then dummy functions will be substituted; the ARIBAS function ** timer and the random initialization will not work properly, ** but the rest will be unchanged. ** Unjustified error message "Too deeply nested recursion" ** can be avoided by defining StackDUM */ #ifdef genUNiX #define StackDUM #ifdef SysDUM #define TimeDUM #endif #endif #ifdef UNiXorGCC #ifndef TimeDUM #include #ifdef SCOUNiX #include #include #else /* ifndef SCOUNiX */ #include static struct timezone t_z = {0,0}; #endif #endif /* TimeDUM */ #endif #ifndef DirDUM #if defined(genUNiX) || defined(DjGPP) #include #endif #ifdef Win32CON #include #endif #endif #ifdef ATARIST #include #include int contrl[12], intin[128], intout[128], ptsin[128], ptsout[128]; int work_in[12], work_out[57]; PUBLIC int VDI_handle; #endif PUBLIC void stacklimit (void); PUBLIC long stkcheck (void); PUBLIC long timer (void); PUBLIC long datetime (int tim[6]); PUBLIC int sysrand (void); PUBLIC void prologue (void); PUBLIC int epilogue (void); PUBLIC char *getworkdir (void); PUBLIC int setworkdir (char *pfad); /*-------------------------------------------------------------*/ PRIVATE long StackLimit; #ifdef MsDOS #define STACKLEN 50000 /* changed for MSVC, 98-04-12 */ extern unsigned _stklen = STACKLEN; #endif #ifdef genUNiX #define STACKLEN 400000 #endif #ifdef MsWIN32 #define STACKLEN 128000 #endif #ifdef DjGPP #define STACKLEN 128000 #endif /*-------------------------------------------------------------*/ #ifdef ATARIST PUBLIC void stacklimit() { extern long _StkLim; /* im Startmodul TCSTSTK.O */ StackLimit = _StkLim; } #endif #ifdef MsDOS PUBLIC void stacklimit() { char ptr; StackLimit = (long)&ptr - (long)_stklen; } #endif #if defined(UNiXorGCC) || defined(MsWIN32) PUBLIC void stacklimit() { char ptr; StackLimit = (long)&ptr - STACKLEN; } #endif /*-------------------------------------------------------------*/ /* ** Returns length of free stack; used in EVAL.C ** not very portable! */ PUBLIC long stkcheck() { long len; #ifdef StackDUM len = 32000; #else extern long StackLimit; char stkptr; len = (long)&stkptr - StackLimit; #endif return(len); } /*-------------------------------------------------------------*/ #ifdef ATARIST #define TMULT 5 #endif #ifdef MsDOS #define TMULT 54 #endif #ifdef MsWIN32 #define TMULT 1 #endif #if defined(DOSorTOS) || defined(MsWIN32) PUBLIC long timer() { long t = clock(); t *= TMULT; return(t); } #endif #ifdef UNiXorGCC PUBLIC long timer() { #ifdef TimeDUM return(0); #else #ifdef SCOUNiX struct timeb tb; ftime(&tb); return(tb.time*1000 + tb.millitm); #else struct timeval tv; gettimeofday(&tv,&t_z); return(tv.tv_sec * 1000 + tv.tv_usec/1000); #endif #endif } #endif /*-------------------------------------------------------------*/ PUBLIC long datetime(tim) int tim[6]; { #ifdef TimeDUM int k; for(k=0; k<6; k++) tim[k] = 0; tim[2] = 1; return(0); #else time_t secs; struct tm *gmt; long t0 = 946684800; /* seconds from Jan 1, 1970 to Jan 1, 2000 */ secs = time(NULL); gmt = gmtime(&secs); tim[0] = gmt->tm_year; tim[1] = gmt->tm_mon; tim[2] = gmt->tm_mday; tim[3] = gmt->tm_hour; tim[4] = gmt->tm_min; tim[5] = gmt->tm_sec; return (long)secs - t0; #endif } /*-------------------------------------------------------------*/ #ifdef ATARIST PUBLIC int sysrand() { return clock(); } #endif #if defined(MsDOS) || defined(MsWIN32) PUBLIC int sysrand() { /* randomize(); */ /* works with BORLAND C++ */ srand((unsigned)time(NULL)); return(rand()); } #endif #ifdef UNiXorGCC PUBLIC int sysrand() { #ifdef SCOUNiX struct timeb tb; ftime(&tb); return(tb.time*1000 + tb.millitm); #else #ifndef TimeDUM struct timeval tv; gettimeofday(&tv,&t_z); return(tv.tv_usec); #else return timer() + 37421; #endif #endif } #endif /*------------------------------------------------------------------*/ PUBLIC char *getworkdir() { static char pfad[MAXPFADLEN]; #if defined(Win32GUI) int res; res = getwwdir(pfad,MAXPFADLEN); /* from file winproc.c */ if(res == 0) pfad[0] = '\0'; #elif defined(Win32CON) || defined(DjGPP) || defined(genUNiX) if (getcwd(pfad,MAXPFADLEN) == NULL) pfad[0] = '\0'; #else pfad[0] = '\0'; #endif return pfad; } /*------------------------------------------------------------------*/ /* ** Returns 0 on failure */ PUBLIC int setworkdir(pfad) char *pfad; { int res; #ifdef Win32CON int drive; #endif #if defined(Win32GUI) return setwwdir(pfad); /* from file winproc.c */ #elif defined(Win32CON) if(strncmp(pfad+1,":\\",2) == 0) { drive = toupcase(pfad[0]) - 'A'; if(drive >= 0 && drive < 26) setdisk(drive); } res = chdir(pfad); return (!res); #elif defined(genUNiX) || defined(DjGPP) res = chdir(pfad); return (!res); #endif return 0; } /*------------------------------------------------------------------*/ PUBLIC void prologue() { #ifdef ATARIST int i, handle; int dum; if(appl_init() < 0) { puts("error in appl_init"); exit(1); } for(i=1; i<10; i++) work_in[i] = 0; work_in[10] = 2; work_in[0] = graf_handle(&dum, &dum, &dum, &dum); v_opnvwk(work_in, &handle, work_out); if(handle <= 0) { puts("error during program initialization"); exit(2); } v_hide_c(handle); v_enter_cur(handle); VDI_handle = handle; #endif #ifdef DOSorUNiX signal(SIGINT,ctrlcreset); #endif return; } /*------------------------------------------------------------------*/ PUBLIC int epilogue() { int ret = 0; #ifdef ATARIST v_exit_cur(VDI_handle); v_show_c(VDI_handle,1); v_clsvwk(VDI_handle); ret = appl_exit(); #endif return(ret); } /*****************************************************************/ aribas165b/src/terminal.c0000644000076600000240000010050214660570650014343 0ustar ottostaff/****************************************************************/ /* file terminal.c ARIBAS interpreter for Arithmetic Copyright (C) 1996-2002 O.Forster This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Address of the author Otto Forster Math. Institut der LMU Theresienstr. 39 D-80333 Muenchen, Germany Email forster@mathematik.uni-muenchen.de */ /****************************************************************/ /* ** terminal.c ** terminal input ** ** date of last change ** 1995-01-25 str0[] in initerm ** 1995-03-10 fixed bug in Fsaveinput ** 1995-03-22 treadline changed ** 1997-03-31 moved comprline inside #ifdef PAGEINPUT ** 1997-04-13 reorg (newintsym) ** 1998-10-28 adjustments for Win32GUI ** 1999-04-27 HISTBOX ** 1999-05-11 fixed problems with signed char in expandtabs ** 2002-02-16 testcomment */ #include "common.h" #ifdef DOSorTOS #ifndef LINEINPUT #define PAGEINPUT #define GETKEY #include "console.inc" #endif #endif #include "logscr.inc" #ifdef genWinGUI #define HISTBOX #endif PUBLIC void initerm (void); PUBLIC void inputprompt (void); PUBLIC void dumpinput (void); PUBLIC char *treadline (void); PUBLIC void historyout (int flg); PUBLIC truc historsym, savinsym, bufovflsym; #ifdef genWinGUI PUBLIC int testcomment(char *buf); #endif /*--------------------------------------------------------*/ PRIVATE void loadinput (char *str); PRIVATE int tinput (void); PRIVATE int expandtabs (char *dest, char *src, int tabwidth); PRIVATE truc Fsaveinput (int argn); PRIVATE int filout (int ch); PRIVATE int getinpbuf (int n); PRIVATE int inploop (void); PRIVATE int endtest (int curline); PRIVATE void protocinput (byte *str); PRIVATE void inputout (byte *str, ifun putfun); PRIVATE void historydisp (void); PRIVATE int previnput (int k); PRIVATE void display (void); PRIVATE truc nullinp; PRIVATE trucptr *inpPtr; #ifdef GETKEY PRIVATE truc Fgetkey (void); PRIVATE truc getkeysym; #endif #ifdef PAGEINPUT PRIVATE truc Floadedit (void); PRIVATE void getloadedit (void); PRIVATE int liesein (char *buffer, FILE *fptr); PRIVATE char *comprline (char *cpt, char *buf); PRIVATE int processkey (int key); PRIVATE int printable (int ch); PRIVATE void repaint (int startrow, int line0, int n); PRIVATE void curdown (int curline); PRIVATE void curup (int curline); PRIVATE void clrzeilrest (int curline, int col); PRIVATE void delzeile (int curline); PRIVATE void backspace (int curline); PRIVATE void mergelines (int curline); PRIVATE void tabright (int curline, int tabwidth); PRIVATE void tableft (int curline, int tabwidth); PRIVATE void startpage (void); PRIVATE void endpage (void); PRIVATE void retbreak (int curline); PRIVATE void opennl (void); PRIVATE void crnewline (int curline); PRIVATE truc loadedsym; PRIVATE int Load_edit = 0; /* Row0 gibt an, wo auf dem Bildschirm Zeile 0 der Eingabe ist*/ PRIVATE int Row0; #else /* #ifndef PAGEINPUT */ PRIVATE int processline (char *line); #endif PRIVATE char prompt[] = "==> "; PRIVATE char quitstring[] = "exit"; PRIVATE int Hist_out = 0; PRIVATE int newinput = 1; PRIVATE int endinput = 1; PRIVATE FILE *savfil; PRIVATE byte *Input; PRIVATE int inpcursor = 0; PRIVATE char TinpBuf[LINELEN] = {EOL}; /* line buffer for terminal input */ #define EXPANDMAX 255 #define ETABWIDTH 8 /* tabwidth of loaded text */ #ifdef PAGEINPUT #define TABWIDTH 4 PRIVATE int tabwidth = TABWIDTH; #endif #define HISTIMAX 4 #ifdef HISTBOX PRIVATE void HB_ini (void); PRIVATE int HB_anz (void); PRIVATE char *HB_retrieve (int k); PRIVATE int HB_store (char *str); PRIVATE int HB_export (int k); PRIVATE int HB_import (int k); #define HB_MAXITEM 36 #define HB_SIZE 8000 PRIVATE struct { char Buffer[HB_SIZE]; int Entry[HB_MAXITEM]; int bot; int ceil; int last; } HB_Box; #endif /* HISTBOX */ /*------------------------------------------------------------*/ PUBLIC void initerm() { static char text[24]; static trucptr ptrarr[4+HISTIMAX]; static char inam[] = "$_"; static char str0[] = " 0."; truc tempsym; int k; inpPtr = ptrarr + 3; str0[0] = strlen(prompt) + 1; nullinp = mkstr(str0); for(k=-3; k<=HISTIMAX; k++) { inam[1] = 'd'+k; tempsym = newsym(inam, sINTERNVAR, nullinp); inpPtr[k] = SYMBINDPTR(&tempsym); } #ifdef HISTBOX HB_ini(); #endif historsym = newintsym("!",sINTERNAL, (wtruc)0); SYMbind(historsym) = constone; #ifndef genWinGUI savinsym = newsymsig("save_input",sFBINARY,(wtruc)Fsaveinput,s_12ii); #endif /* genWinGUI */ #ifdef PAGEINPUT loadedsym = newsymsig("load_edit", sFBINARY,(wtruc)Floadedit, s_bs); #endif #ifdef GETKEY getkeysym = newsymsig("get_key", sFBINARY,(wtruc)Fgetkey, s_0); #endif s1form(text,"more than ~D lines",intcast(BUFLINES)); bufovflsym = newselfsym(text,sINTERNAL); } /*------------------------------------------------------------*/ #ifdef HISTBOX PRIVATE void HB_ini() { int k; for(k=0; k HB_Box.last) return NULL; else { pos = HB_Box.Entry[k]; return (HB_Box.Buffer + pos); } } /*-----------------------------------------------------------*/ PRIVATE int HB_store(str) char *str; { char *Buffer = HB_Box.Buffer; int *Entry = HB_Box.Entry; int bot = HB_Box.bot; int ceil = HB_Box.ceil; int last = HB_Box.last; int len = strlen(str)+1; int len1, ceil1, diff, k; char *ptr1, *ptr2; if(len > HB_SIZE/2) return(-1); while((len > ceil - bot) || last >= HB_MAXITEM-1) { last--; ceil1 = Entry[last]; if(ceil1 < bot) { diff = HB_SIZE - bot; len1 = bot - ceil1; ptr1 = Buffer + ceil1; ptr2 = ptr1 + diff; while(--len1 >= 0) *ptr2++ = *ptr1++; for(k=0; k<=last; k++) Entry[k] += diff; ceil = ceil1 + diff; bot = 0; } else ceil = ceil1; } last++; for(k=last; k>0; k--) Entry[k] = Entry[k-1]; strcpy(Buffer+bot,str); Entry[0] = bot; HB_Box.bot = bot + len; HB_Box.ceil = ceil; HB_Box.last = last; return(len); } /*-----------------------------------------------------------*/ PRIVATE int HB_export(k) int k; { char *str; str = (char *)STRINGPTR(inpPtr[k]); return HB_store(str); } /*-----------------------------------------------------------*/ PRIVATE int HB_import(k) int k; { int anz; char *str; anz = HB_anz(); k -= HISTIMAX + 1; if(k < 0 || anz <= 0) { *inpPtr[0] = nullinp; return 0; } if(k >= anz) k = anz-1; str = HB_retrieve(k); *inpPtr[0] = mkstr(str); return (k + HISTIMAX + 1); } /*------------------------------------------------------------*/ #endif /* HISTBOX */ /*------------------------------------------------------------*/ PUBLIC void inputprompt() { if(endinput) newinput = 1; } /*------------------------------------------------------------*/ PUBLIC void dumpinput() { newinput = 1; } /*------------------------------------------------------------*/ /* ** read line from terminal */ PUBLIC char *treadline() { char *str; int ch; int ret = 1; if(newinput) { #ifndef genWinGUI if(!Hist_out) fnewline(tstdout); #endif STRMlineno(tstdin) = 0; ret = inploop(); getinpbuf(1); inpcursor = 0; newinput = 0; endinput = 0; } str = TinpBuf; if(ret >= 0) { ch = tinput(); while(ch >= ' ') { *str++ = ch; ch = tinput(); } } else { *str++ = ZESC; *str++ = '\001'; } *str = EOL; return(TinpBuf); } /*------------------------------------------------------------*/ PRIVATE void loadinput(str) char *str; { if(!Hist_out) { #ifdef HISTBOX HB_export(4); #endif *inpPtr[4] = *inpPtr[3]; *inpPtr[3] = *inpPtr[2]; *inpPtr[2] = *inpPtr[1]; } else Hist_out = 0; *inpPtr[1] = nullinp; /* release memory */ *inpPtr[1] = mkstr(str); } /*--------------------------------------------------------------*/ PRIVATE int tinput() { int ch; ch = Input[inpcursor++]; if(ch >= ' ') { return(ch); } else if(ch == 0) { endinput = 1; return(FORMFEED); } else { if(ch == TABESC) inpcursor++; return(EOL); } } /*-------------------------------------------------------------------*/ /* ** Ersetzt die TABs des Strings src durch die entsprechende ** Zahl von Leerzeichen. Die Umwandlung wird beendet, sobald ** ein EOL oder ein Nullbyte angetroffen wird. ** Sonstige Zeichen mit Ascii-Code < ' ' werden durch Leerzeichen ** ersetzt. ** Es wird vorausgesetzt, dass der Puffer dest genuegend lang ist. ** Spaetestens nach EXPANDMAX Zeichen wird der expandierte ** String abgeschnitten. ** Leer- und Steuerzeichen am Ende des Strings werden ** ebenfalls abgeschnitten. ** Rueckgabewert ist die Laenge des expandierten Strings. */ PRIVATE int expandtabs(dest,src,tabwidth) char *dest, *src; int tabwidth; { char *ptr; int k, len = 0; int ch; ptr = dest; while(len < EXPANDMAX) { ch = *src++; if(ch == EOL || ch == 0) break; else if(ch == '\t') { k = ((len+tabwidth)/tabwidth) * tabwidth; if(k > EXPANDMAX) k = EXPANDMAX; while(len < k) { *ptr++ = ' '; len++; } } else { *ptr++ = ((byte)ch >= ' ' ? ch : ' '); len++; } } while(len > 0 && (byte)dest[len-1] <= ' ') len--; dest[len] = '\0'; return(len); } /*-------------------------------------------------------------------*/ #ifndef genWinGUI PRIVATE truc Fsaveinput(argn) int argn; { truc *argptr; int k, k0; int flg; char *str; char name[MAXPFADLEN+2]; argptr = argStkPtr - argn + 1; if(argn == 2) { flg = *FLAGPTR(argStkPtr); if(flg == fFIXNUM || flg == fCHARACTER) { k = *WORD2PTR(argStkPtr); if(k >= 'a' && k <= 'c') k0 = 'a' - k - 1; else if(k >= 1 && k <= 3) { k0 = k + 1; } else goto errex1; } else { errex1: error(savinsym, "integer 1,2,3 or character 'a', 'b' or 'c' expected", *argStkPtr); goto errexit; } } else k0 = 2; flg = *FLAGPTR(argptr); if(flg == fCHARACTER) { k = *WORD2PTR(argptr); if(k < 'a' || k > 'c') { error(savinsym, "character 'a', 'b' or 'c' expected",*argptr); goto errexit; } *inpPtr['a' - k - 1] = mkcopy(inpPtr[k0]); } else if(flg == fSTRING) { str = STRINGPTR(argptr); if(!str[0]) goto errexit; fnextens(str,name,ariExtens); savfil = fopen(name,"w"); if(savfil == NULL) { error(savinsym,err_open,scratch(name)); goto errexit; } str = STRINGPTR(inpPtr[k0]); inputout((byte *)str,filout); fclose(savfil); } else { error(savinsym, "filename or character 'a', 'b' or 'c' expected", *argStkPtr); goto errexit; } return(*argptr); errexit: return(false); } #endif /* genWinGUI */ /*-------------------------------------------------------------------*/ PRIVATE int filout(ch) int ch; { return(fputc(ch,savfil)); } /*-------------------------------------------------------------------*/ PRIVATE int getinpbuf(n) int n; { int ret = n; #ifdef HISTBOX if(n > HISTIMAX) { ret = HB_import(n); n = 0; } #endif Input = (byte *)STRINGPTR(inpPtr[n]); return(ret); } /*-------------------------------------------------------------------*/ PRIVATE int endtest(curline) int curline; { char *str; int ch; int k, k1; int ret = 0; k = L_trimlen(curline); ch = L_linerest(curline,k)[0]; #ifdef PAGEINPUT if(Col <= k) ch = 0; #endif if(ch == '.' || ch == '?') { ret = 1; } else if(curline == L_efffirst()) { k1 = L_indent(curline); str = L_linerest(curline,k1+1); if(str[0] == '!' || strcmp(str,quitstring) == 0) { ret = 1; } } if(ret == 1) { if(L_insidecomment(curline) == 1) ret = 0; } return(ret); } /*-------------------------------------------------------------------*/ PRIVATE void protocinput(str) byte *str; { int indent = strlen(prompt); if(indent >= str[0]) indent = 0; str[0] -= indent; inputout(str,logout); str[0] += indent; } /*-------------------------------------------------------------------*/ PRIVATE void inputout(str,putfun) byte *str; ifun putfun; { int ch, k; ch = *str++; while(ch) { if(ch < TABESC-1) k = ch - 1; else if(ch == TABESC) k = *str++; else k = 0; while(--k >= 0) putfun(' '); while((ch = *str++) > TABESC) putfun(ch); putfun('\n'); } } /*-------------------------------------------------------------------*/ PUBLIC void historyout(flg) int flg; { Hist_out = flg; } /*-------------------------------------------------------------------*/ PRIVATE void historydisp() { int k; k = SYMbind2(historsym); if(k >= 1 && k <= 3) k++; else if(k >= 'a' || k <= 'c') k = 'a' - k - 1; else k = 2; previnput(k); } /*-------------------------------------------------------------------*/ PRIVATE int previnput(k) int k; { k = getinpbuf(k); L_expand(Input); display(); return k; } /*-------------------------------------------------------------------*/ #ifdef genWinGUI PUBLIC int cpyprevinput(buf,k) char *buf; int k; { char InpBuf[BUFLINES][LINELEN]; int i, n; char *str; Col0 = L_iniscr(InpBuf,prompt); k = getinpbuf(k); L_expand(Input); n = L_efflen() - 1; for(i=0; i<=n; i++) { str = L_line(i) + (i==0 ? Col0-1 : 0); buf += strcopy(buf,str); if(i < n) { #ifdef Win32GUI buf += strcopy(buf,"\r\n"); #else buf += strcopy(buf,"\n"); #endif } } *buf = '\0'; return k; } /*-------------------------------------------------------------------*/ PUBLIC int testcomment(buf) char *buf; { char InpBuf[BUFLINES][LINELEN]; int curline; int ret; Col0 = L_iniscr(InpBuf,prompt); curline = L_text2blatt(buf)-1; if(curline < 0) ret = -1; else ret = L_insidecomment(curline); return ret; } /*-------------------------------------------------------------------*/ #endif /*-------------------------------------------------------------------*/ #ifndef PAGEINPUT /*-------------------------------------------------------------------*/ PRIVATE int inploop() { char InpBuf[BUFLINES][LINELEN]; char linebuf[LINELEN]; int ret = 1; char *str; #ifdef genWinGUI char *winbuf; int k, ch; #endif Col0 = L_iniscr(InpBuf,prompt); #ifndef genWinGUI if(Hist_out) { historydisp(); } else { fprintstr(tstdout,prompt); while(1) { str = fgets(linebuf,LINELEN-3,stdin); if(str == NULL) { strcopy(linebuf,quitstring); } ret = processline(linebuf); if(ret <= 0) break; } } #else /* ifdef genWinGUI */ winbuf = getWinscrBuf(); while(1) { str = linebuf; for(ch=*winbuf++,k=1; (ch && ch!='\n' && k<=LINELEN-3); k++) { *str++ = ch; ch = *winbuf++; } *str = '\0'; ret = processline(linebuf); if(ret <= 0 || ch == 0) break; } #endif /* ?genWinGUI */ L_compress(); str = InpBuf[0]; if(Log_on) { protocinput((byte *)str); } loadinput(str); return(ret); } /*-------------------------------------------------------------------*/ PRIVATE int processline(line) char *line; { char expandbuf[EXPANDMAX+1]; int lineno, len, n; int ret, fertig; lineno = L_pagelen() - 1; len = L_len(lineno); n = expandtabs(expandbuf,line,ETABWIDTH); L_strappend(lineno,len+1,expandbuf); ret = L_insert(lineno+1); fertig = endtest(lineno); if(ret == 0 && fertig == 0) return(-1); else if(fertig) return(0); else return(ret); } /*-------------------------------------------------------------------*/ PRIVATE void display() { char *str; int i, n; n = L_efflen(); for(i=0; i= MaxRow) { startrow = 1; line0 = n - MaxRow; n = MaxRow; } else if(Row0 + n - 1 > MaxRow) { k = Row0 + n - 1 - MaxRow; while(--k >= 0) scrollup(); startrow = MaxRow - n + 1; line0 = 0; } else if(Row0 <= 0) { startrow = 1; line0 = 0; } else { startrow = Row0; line0 = 0; } Row0 = startrow - line0; repaint(startrow,line0,n); } /*-------------------------------------------------------------------*/ PRIVATE int liesein(buffer,fptr) char *buffer; FILE *fptr; { char expandbuf[EXPANDMAX+1]; char linbuf[LINELEN]; char *cpt; int count, len; cpt = buffer; for(count=0; count= (LINELEN-2) - Col0 - 1) { *cpt++ = '\001'; count = 1; } cpt = comprline(cpt,expandbuf); } } if(!count) *cpt++ = '\001'; *cpt = 0; fclose(fptr); return(count); } /*-------------------------------------------------------------------*/ /* ** Uebersetzt die Zeile buf in das interne ** Compress-Format (siehe L_compress in LOGSCR.INC) ** Es wird vorausgesetzt, dass buff keine TABs mehr enthaelt. */ PRIVATE char *comprline(cpt,buf) char *cpt, *buf; { int k = 0; int ch; while((ch = *buf) == ' ') { buf++; k++; } if(k <= TABESC - 2) { *cpt++ = k+1; } else { *cpt++ = TABESC; *cpt++ = k; } while((ch = *buf++)) *cpt++ = ch; return(cpt); } /*-------------------------------------------------------------------*/ PRIVATE truc Floadedit() { char Buffer[BUFLINES * LINELEN]; char name[84]; char *str; int errflg = 0; int ret; FILE *fptr; if(*FLAGPTR(argStkPtr) == fSTRING) { str = STRINGPTR(argStkPtr); errflg = (str[0] ? 0 : 1); } else errflg = 1; if(errflg) { error(loadedsym,err_str,*argStkPtr); return(brkerr()); } fnextens(str,name,ariExtens); fptr = fopen(name,"r"); if(fptr == NULL) { error(loadedsym,err_open,scratch(name)); return(false); } ret = liesein(Buffer,fptr); if(ret < 0) { if(ret == -1) error(loadedsym,"input file too long",voidsym); else error(loadedsym,"inadmissible input",voidsym); return(false); } Load_edit = 1; *inpPtr[0] = mkstr(Buffer); return(true); } /*-------------------------------------------------------------------*/ PRIVATE void getloadedit() { previnput(0); Load_edit = 0; *inpPtr[0] = nullinp; /* release memory */ } /*-------------------------------------------------------------------*/ PRIVATE int processkey(key) int key; { char *str; int curline; int k, n; int ret = 1; nochmal: curline = Row - Row0; switch(key) { case CURDOWN: curdown(curline); break; case CURUP: curup(curline); break; case CURRIGHT: if(Col < MaxCol) { Col++; cursorto(Row,Col); } break; case CURLEFT: if(Col > 1) { if(curline > 0 || Col > Col0) Col--; cursorto(Row,Col); } break; case DELETE: n = L_chardel(curline,Col); if(n) { str = L_linerest(curline,Col); clineout(str); } break; case DELLINE: if(curline == 0) clrzeilrest(0,Col0); else delzeile(curline); break; case DELWORD: k = L_nextword(curline,Col); if(k > Col) { L_charndel(curline,Col,k-Col); str = L_linerest(curline,Col); clineout(str); } break; case BACKSPACE: if((curline > 0 && Col > 1) || Col > Col0) backspace(curline); else if(Col == 1 && curline > 0 && Row > 1) mergelines(curline); break; case STARTLINE: Col = (curline > 0 ? 1 : Col0); cursorto(Row,Col); break; case ENDLINE: n = L_len(curline); cursorto(Row,n+1); break; case TABRIGHT: tabright(curline,tabwidth); break; case TABLEFT: tableft(curline,tabwidth); break; case CTRLRIGHT: n = L_nextgroup(curline,Col); cursorto(Row,n); break; case CTRLLEFT: n = L_prevgroup(curline,Col); cursorto(Row,n); break; case STARTPAGE: startpage(); break; case ENDPAGE: endpage(); break; case TOPSCREEN: if(Row == 1) curup(curline); else { Row = (Row0 > 1 ? Row0 : 1); if(Row0 >= 1 && Col < Col0) Col = Col0; cursorto(Row,Col); } break; case BOTSCREEN: if(Row == MaxRow) curdown(curline); else { n = Row0 + L_pagelen() - 1; if(n >= MaxRow) Row = MaxRow; else if(n > 1) Row = n; else Row = 1; cursorto(Row,Col); } break; case RETURN: if(curline == L_efflen()-1 && endtest(curline)) { if(Row == MaxRow) scrollup(); else Row++; cursorto(Row,1); ret = 0; } else if(Col > L_len(curline) && curline < L_pagelen()-1 && L_len(curline+1) == 0) { crnewline(curline); } else retbreak(curline); break; case CTRLRET: if(curline == L_efflen()-1 && endtest(curline)) { if(Row == MaxRow) scrollup(); else Row++; cursorto(Row,1); ret = 0; } else if(curline < L_pagelen()-1 && L_len(curline+1) == 0) { crnewline(curline); } else if(L_insert(curline+1)) opennl(); break; case PREVINP1: previnput(1); break; case PREVINP2: previnput(2); break; case PREVINP3: previnput(3); break; case PREVINP4: previnput(4); break; case PREVINPA1: previnput(-1); break; case PREVINPA2: previnput(-2); break; case PREVINPA3: previnput(-3); break; case ESCKEY: key = keyin(); if(key == ESCKEY) { endpage(); key = '.'; ret = 0; } goto nochmal; default: if(printable(key)) { n = L_charins(curline,Col,key,MaxCol-1); if(n) { str = L_linerest(curline,Col); clineout(str); Col = Col++; cursorto(Row,Col); } } break; } return(ret); } /*-------------------------------------------------------------------*/ PRIVATE int printable(code) int code; { if(code & 0xFF00) return(0); else if(' ' <= code && code != '\177') return(1); else return(0); } /*-------------------------------------------------------------------*/ /* ** Schreibt ab Zeile startrow insgesamt n Zeilen des Dokuments, ** beginnend mit Zeile line0, auf den Bildschirm und loescht den ** Rest des Bildschirms. ** Es wird vorausgesetzt, dass (startrow + n - 1) <= MaxRow ** und line0 + n <= Laenge des Dokuments. */ PRIVATE void repaint(startrow,line0,n) int startrow, line0, n; { int i; char *str; for(i=0; i= L_pagelen() - 1) return; if(Row < MaxRow) { Row++; } else { scrollup(); Row0--; temp = Col; str = L_line(curline+1); cursorto(MaxRow,1); clineout(str); Col = temp; } cursorto(Row,Col); } /*-------------------------------------------------------------------*/ PRIVATE void curup(curline) int curline; { int temp; char *str; if(curline == 1 && Col < Col0) cursorto(Row,Col0); if(curline == 0) return; if(Row > 1) { Row--; } else { scrolldown(); Row0++; temp = Col; str = L_line(curline-1); cursorto(1,1); clineout(str); Col = temp; } cursorto(Row,Col); } /*-------------------------------------------------------------------*/ PRIVATE void clrzeilrest(curline,col) int curline, col; { L_clreol(curline,col); cursorto(Row,col); cleareol(); } /*-------------------------------------------------------------------*/ PRIVATE void delzeile(curline) int curline; { int n, temp; char *str; n = L_pagelen(); if(n > 1) { L_delete(curline); if(curline == n-1 && Row == 1) { cursorto(1,1); str = L_line(curline-1); clineout(str); Row0++; } else { deleteline(); if(MaxRow - Row0 < n-1) { temp = Row; str = L_line(MaxRow - Row0); cursorto(MaxRow,1); clineout(str); Row = temp; } else if(curline == n-1) Row--; } Col = (Row == Row0 ? Col0 : 1); cursorto(Row,Col); } } /*-------------------------------------------------------------------*/ PRIVATE void backspace(curline) int curline; { int n; char *str; Col--; n = L_chardel(curline,Col); cursorto(Row,Col); if(n) { str = L_linerest(curline,Col); clineout(str); } } /*-------------------------------------------------------------------*/ PRIVATE void mergelines(curline) int curline; { int n, col0, temp; char *str; col0 = L_merge(curline-1,MaxCol-1); if(col0) { deleteline(); n = MaxRow - Row0; if(n < L_pagelen()-1) { temp = Row; str = L_line(n); cursorto(MaxRow,1); clineout(str); Row = temp; } str = L_linerest(curline-1,col0); cursorto(Row-1,col0); clineout(str); } } /*-------------------------------------------------------------------*/ PRIVATE void tabright(curline,tabwidth) int curline, tabwidth; { int n, k; char *str; n = L_len(curline); k = tabwidth - (Col - 1) % tabwidth; if(Col <= n) { k = L_spaceins(curline,Col,k,MaxCol-1); if(n) { str = L_linerest(curline,Col); clineout(str); cursorto(Row,Col+k); } } else if(Col+k <= MaxCol) cursorto(Row,Col+k); } /*-------------------------------------------------------------------*/ PRIVATE void tableft(curline,tabwidth) int curline, tabwidth; { int k; char *str; k = (Col - 1) % tabwidth; if(k == 0 && Col > tabwidth) k = tabwidth; if(curline == 0 && Col-k < Col0) { k = Col - Col0; Col = Col0; } else Col = Col - k; L_charndel(curline,Col,k); cursorto(Row,Col); str = L_linerest(curline,Col); clineout(str); } /*-------------------------------------------------------------------*/ PRIVATE void startpage() { int i, k; char *str; if(Row0 >= 1) { cursorto(Row0,Col0); } else { k = 1 - Row0; Row0 = 1; if(k > MaxRow) k = MaxRow; cursorto(1,1); for(i=k-1; i>=0; i--) { scrolldown(); str = L_line(i); clineout(str); } cursorto(1,Col0); } } /*-------------------------------------------------------------------*/ PRIVATE void endpage() { char *str; int i, k, n; n = L_efflen() - 1; k = Row0 + n; if(k <= MaxRow) { cursorto(k,L_len(n)+1); } else { k = Row0 + n - MaxRow; Row0 -= k; if(k > MaxRow) k = MaxRow; cursorto(MaxRow,1); for(i=k-1; i>=0; i--) { scrollup(); str = L_line(n-i); clineout(str); } cursorto(MaxRow,L_len(n)+1); } } /*-------------------------------------------------------------------*/ PRIVATE void retbreak(curline) int curline; { char *str; if(L_retbreak(curline,Col)) { cleareol(); opennl(); str = L_line(curline+1); clineout(str); } } /*-------------------------------------------------------------------*/ PRIVATE void opennl() { if(Row < MaxRow) { Row++; cursorto(Row,1); if(Row < MaxRow) insertline(); else cleareol(); } else { scrollup(); Row0--; cursorto(MaxRow,1); } } /*-------------------------------------------------------------------*/ PRIVATE void crnewline(curline) { curdown(curline); cursorto(Row,1); } /*------------------------------------------------------------*/ #endif /* ?PAGEINPUT */ /*------------------------------------------------------------*/ #ifdef GETKEY /*------------------------------------------------------------*/ PRIVATE truc Fgetkey() { unsigned key = keyin(); return(mkfixnum(key)); } /*------------------------------------------------------------*/ #endif /*********************************************************************/