home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1994 March / Source_Code_CD-ROM_Walnut_Creek_March_1994.iso / compsrcs / unix / volume26 / calc / part20 < prev    next >
Encoding:
Text File  |  1992-05-09  |  49.5 KB  |  2,014 lines
  1. Newsgroups: comp.sources.unix
  2. From: dbell@pdact.pd.necisa.oz.au (David I. Bell)
  3. Subject: v26i046: CALC - An arbitrary precision C-like calculator, Part20/21
  4. Sender: unix-sources-moderator@pa.dec.com
  5. Approved: vixie@pa.dec.com
  6.  
  7. Submitted-By: dbell@pdact.pd.necisa.oz.au (David I. Bell)
  8. Posting-Number: Volume 26, Issue 46
  9. Archive-Name: calc/part20
  10.  
  11. #! /bin/sh
  12. # This is a shell archive.  Remove anything before this line, then unpack
  13. # it by saving it into a file and typing "sh file".  To overwrite existing
  14. # files, type "sh file -c".  You can also feed this as standard input via
  15. # unshar, or by typing "sh <file", e.g..  If this archive is complete, you
  16. # will see the following message at the end:
  17. #        "End of archive 20 (of 21)."
  18. # Contents:  func.c
  19. # Wrapped by dbell@elm on Tue Feb 25 15:21:18 1992
  20. PATH=/bin:/usr/bin:/usr/ucb ; export PATH
  21. if test -f 'func.c' -a "${1}" != "-c" ; then 
  22.   echo shar: Will not clobber existing file \"'func.c'\"
  23. else
  24. echo shar: Extracting \"'func.c'\" \(47105 characters\)
  25. sed "s/^X//" >'func.c' <<'END_OF_FILE'
  26. X/*
  27. X * Copyright (c) 1992 David I. Bell
  28. X * Permission is granted to use, distribute, or modify this source,
  29. X * provided that this copyright notice remains intact.
  30. X *
  31. X * Built-in functions implemented here
  32. X */
  33. X
  34. X#include <sys/types.h>
  35. X#include <sys/times.h>
  36. X#include <time.h>
  37. X
  38. X#include "calc.h"
  39. X#include "opcodes.h"
  40. X#include "token.h"
  41. X#include "func.h"
  42. X#include "string.h"
  43. X
  44. X
  45. X/* if HZ & CLK_TCK are not defined, pick typical values, hope for the best */
  46. X#if !defined(HZ)
  47. X#  define HZ 60
  48. X#endif
  49. X#if !defined(CLK_TCK)
  50. X# undef CLK_TCK
  51. X# define CLK_TCK HZ
  52. X#endif
  53. X
  54. Xextern int errno;
  55. X
  56. X
  57. X/*
  58. X * Totally numeric functions.
  59. X */
  60. Xstatic NUMBER *f_cfsim();    /* simplify number using continued fractions */
  61. Xstatic NUMBER *f_ilog();    /* return log of one number to another */
  62. Xstatic NUMBER *f_faccnt();    /* count of divisions */
  63. Xstatic NUMBER *f_min();        /* minimum of several arguments */
  64. Xstatic NUMBER *f_max();        /* maximum of several arguments */
  65. Xstatic NUMBER *f_hmean();    /* harmonic mean */
  66. Xstatic NUMBER *f_trunc();    /* truncate number to specified decimal places */
  67. Xstatic NUMBER *f_btrunc();    /* truncate number to specified binary places */
  68. Xstatic NUMBER *f_gcd();        /* greatest common divisor */
  69. Xstatic NUMBER *f_lcm();        /* least common multiple */
  70. Xstatic NUMBER *f_xor();        /* xor of several arguments */
  71. Xstatic NUMBER *f_ceil();    /* ceiling of a fraction */
  72. Xstatic NUMBER *f_floor();    /* floor of a fraction */
  73. Xstatic NUMBER *f_meq();        /* numbers are same modular value */
  74. Xstatic NUMBER *f_isrel();    /* two numbers are relatively prime */
  75. Xstatic NUMBER *f_ismult();    /* whether one number divides another */
  76. Xstatic NUMBER *f_mne();        /* whether a and b are not equal modulo c */
  77. Xstatic NUMBER *f_isset();    /* tests if a bit of a num (base 2) is set */
  78. Xstatic NUMBER *f_highbit();    /* high bit number in base 2 representation */
  79. Xstatic NUMBER *f_lowbit();    /* low bit number in base 2 representation */
  80. Xstatic NUMBER *f_near();    /* whether two numbers are near each other */
  81. Xstatic NUMBER *f_legtoleg();    /* positive form of leg to leg */
  82. Xstatic NUMBER *f_ilog10();    /* integer log of number base 10 */
  83. Xstatic NUMBER *f_ilog2();    /* integer log of number base 2 */
  84. Xstatic NUMBER *f_digits();    /* number of digits of number */
  85. Xstatic NUMBER *f_digit();    /* digit at specified decimal place of number */
  86. Xstatic NUMBER *f_places();    /* number of decimal places of number */
  87. Xstatic NUMBER *f_primetest();    /* primality test */
  88. Xstatic NUMBER *f_issquare();    /* whether number is a square */
  89. Xstatic NUMBER *f_runtime();    /* user runtime in seconds */
  90. X
  91. X
  92. X/*
  93. X * General functions.
  94. X */
  95. Xstatic VALUE f_bround();    /* round number to specified binary places */
  96. Xstatic VALUE f_round();        /* round number to specified decimal places */
  97. Xstatic VALUE f_det();        /* determinant of matrix */
  98. Xstatic VALUE f_mattrans();    /* return transpose of matrix */
  99. Xstatic VALUE f_matdim();    /* dimension of matrix */
  100. Xstatic VALUE f_matmax();    /* maximum index of matrix dimension */
  101. Xstatic VALUE f_matmin();    /* minimum index of matrix dimension */
  102. Xstatic VALUE f_matfill();    /* fill matrix with values */
  103. Xstatic VALUE f_listpush();    /* push element onto front of list */
  104. Xstatic VALUE f_listpop();    /* pop element from front of list */
  105. Xstatic VALUE f_listappend();    /* append element to end of list */
  106. Xstatic VALUE f_listremove();    /* remove element from end of list */
  107. Xstatic VALUE f_listinsert();    /* insert element into list */
  108. Xstatic VALUE f_listdelete();    /* delete element from list */
  109. Xstatic VALUE f_strlen();    /* length of string */
  110. Xstatic VALUE f_char();        /* character value of integer */
  111. Xstatic VALUE f_substr();    /* extract substring */
  112. Xstatic VALUE f_strcat();    /* concatenate strings */
  113. Xstatic VALUE f_ord();        /* get ordinal value for character */
  114. Xstatic VALUE f_avg();        /* average of several arguments */
  115. Xstatic VALUE f_ssq();        /* sum of squares */
  116. Xstatic VALUE f_poly();        /* result of evaluating polynomial */
  117. Xstatic VALUE f_sqrt();        /* square root of a number */
  118. Xstatic VALUE f_root();        /* number taken to root of another */
  119. Xstatic VALUE f_exp();        /* complex exponential */
  120. Xstatic VALUE f_ln();        /* complex natural logarithm */
  121. Xstatic VALUE f_power();        /* one value to another power */
  122. Xstatic VALUE f_cos();        /* complex cosine */
  123. Xstatic VALUE f_sin();        /* complex sine */
  124. Xstatic VALUE f_polar();        /* polar representation of complex number */
  125. Xstatic VALUE f_arg();        /* argument of complex number */
  126. Xstatic VALUE f_list();        /* create a list */
  127. Xstatic VALUE f_size();        /* number of elements in object */
  128. Xstatic VALUE f_search();    /* search matrix or list for match */
  129. Xstatic VALUE f_rsearch();    /* search matrix or list backwards for match */
  130. Xstatic VALUE f_cp();        /* cross product of vectors */
  131. Xstatic VALUE f_dp();        /* dot product of vectors */
  132. Xstatic VALUE f_prompt();    /* prompt for input line */
  133. Xstatic VALUE f_eval();        /* evaluate string into value */
  134. Xstatic VALUE f_str();        /* convert value to string */
  135. Xstatic VALUE f_fopen();        /* open file for reading or writing */
  136. Xstatic VALUE f_fprintf();    /* print data to file */
  137. Xstatic VALUE f_strprintf();    /* return printed data as a string */
  138. Xstatic VALUE f_fgetline();    /* read next line from file */
  139. Xstatic VALUE f_fgetc();        /* read next char from file */
  140. Xstatic VALUE f_fflush();    /* flush output to file */
  141. Xstatic VALUE f_printf();    /* print data to stdout */
  142. Xstatic VALUE f_fclose();    /* close file */
  143. Xstatic VALUE f_ferror();    /* whether error occurred */
  144. Xstatic VALUE f_feof();        /* whether end of file reached */
  145. Xstatic VALUE f_files();        /* return file handle or number of files */
  146. X
  147. X
  148. X#define IN 100        /* maximum number of arguments */
  149. X#define    FE 0x01        /* flag to indicate default epsilon argument */
  150. X#define    FA 0x02        /* preserve addresses of variables */
  151. X
  152. X
  153. X/*
  154. X * List of primitive built-in functions
  155. X */
  156. Xstatic struct builtin {
  157. X    char *b_name;        /* name of built-in function */
  158. X    short b_minargs;    /* minimum number of arguments */
  159. X    short b_maxargs;    /* maximum number of arguments */
  160. X    short b_flags;        /* special handling flags */
  161. X    short b_opcode;        /* opcode which makes the call quick */
  162. X    NUMBER *(*b_numfunc)();    /* routine to calculate numeric function */
  163. X    VALUE (*b_valfunc)();    /* routine to calculate general values */
  164. X    char *b_desc;        /* description of function */
  165. X} builtins[] = {
  166. X    "abs", 1, 2, 0, OP_ABS, 0, 0, "absolute value within accuracy b",
  167. X    "acos", 1, 2, FE, OP_NOP, qacos, 0, "arccosine of a within accuracy b",
  168. X    "acosh", 1, 2, FE, OP_NOP, qacosh, 0, "hyperbolic arccosine of a within accuracy b",
  169. X    "append", 2, 2, FA, OP_NOP, 0, f_listappend, "append value to end of list",
  170. X    "appr", 1, 2, FE, OP_NOP, qbappr, 0, "approximate a with simpler fraction to within b",
  171. X    "arg", 1, 2, 0, OP_NOP, 0, f_arg, "argument (the angle) of complex number",
  172. X    "asin", 1, 2, FE, OP_NOP, qasin, 0, "arcsine of a within accuracy b",
  173. X    "asinh", 1, 2, FE, OP_NOP, qasinh, 0, "hyperbolic arcsine of a within accuracy b",
  174. X    "atan", 1, 2, FE, OP_NOP, qatan, 0, "arctangent of a within accuracy b",
  175. X    "atan2", 2, 3, FE, OP_NOP, qatan2, 0, "angle to point (b,a) within accuracy c",
  176. X    "atanh", 1, 2, FE, OP_NOP, qatanh, 0, "hyperbolic arctangent of a within accuracy b",
  177. X    "avg", 1, IN, 0, OP_NOP, 0, f_avg, "arithmetic mean of values",
  178. X    "bround", 1, 2, 0, OP_NOP, 0, f_bround, "round value a to b number of binary places",
  179. X    "btrunc", 1, 2, 0, OP_NOP, f_btrunc, 0, "truncate a to b number of binary places",
  180. X    "ceil", 1, 1, 0, OP_NOP, f_ceil, 0, "smallest integer greater than or equal to number",
  181. X    "cfappr", 1, 2, FE, OP_NOP, qcfappr, 0, "approximate a within accuracy b using continued fractions",
  182. X    "cfsim", 1, 1, 0, OP_NOP, f_cfsim, 0, "simplify number using continued fractions",
  183. X    "char", 1, 1, 0, OP_NOP, 0, f_char, "character corresponding to integer value",
  184. X    "cmp", 2, 2, 0, OP_CMP, 0, 0, "compare values returning -1, 0, or 1",
  185. X    "comb", 2, 2, 0, OP_NOP, qcomb, 0, "combinatorial number a!/b!(a-b)!",
  186. X    "config", 1, 2, 0, OP_SETCONFIG, 0, 0, "set or read configuration value",
  187. X    "conj", 1, 1, 0, OP_CONJUGATE, 0, 0, "complex conjugate of value",
  188. X    "cos", 1, 2, 0, OP_NOP, 0, f_cos, "cosine of value a within accuracy b",
  189. X    "cosh", 1, 2, FE, OP_NOP, qcosh, 0, "hyperbolic cosine of a within accuracy b",
  190. X    "cp", 2, 2, 0, OP_NOP, 0, f_cp, "Cross product of two vectors",
  191. X    "delete", 2, 2, FA, OP_NOP, 0, f_listdelete, "delete element from list a at position b",
  192. X    "den", 1, 1, 0, OP_DENOMINATOR, qden, 0, "denominator of fraction",
  193. X    "det", 1, 1, 0, OP_NOP, 0, f_det, "determinant of matrix",
  194. X    "digit", 2, 2, 0, OP_NOP, f_digit, 0, "digit at specified decimal place of number",
  195. X    "digits", 1, 1, 0, OP_NOP, f_digits, 0, "number of digits in number",
  196. X    "dp", 2, 2, 0, OP_NOP, 0, f_dp, "Dot product of two vectors",
  197. X    "epsilon", 0, 1, 0, OP_SETEPSILON, 0, 0, "set or read allowed error for real calculations",
  198. X    "eval", 1, 1, 0, OP_NOP, 0, f_eval, "Evaluate expression from string to value",
  199. X    "exp", 1, 2, 0, OP_NOP, 0, f_exp, "exponential of value a within accuracy b",
  200. X    "fcnt", 2, 2, 0, OP_NOP, f_faccnt, 0, "count of times one number divides another",
  201. X    "fib", 1, 1, 0, OP_NOP, qfib, 0, "fibonacci number F(n)",
  202. X    "frem", 2, 2, 0, OP_NOP, qfacrem, 0, "number with all occurances of factor removed",
  203. X    "fact", 1, 1, 0, OP_NOP, qfact, 0, "factorial",
  204. X    "fclose", 1, 1, 0, OP_NOP, 0, f_fclose, "close file",
  205. X    "feof", 1, 1, 0, OP_NOP, 0, f_feof, "whether EOF reached for file",
  206. X    "ferror", 1, 1, 0, OP_NOP, 0, f_ferror, "whether error occurred for file",
  207. X    "fflush", 1, 1, 0, OP_NOP, 0, f_fflush, "flush output to file",
  208. X    "fgetc", 1, 1, 0, OP_NOP, 0, f_fgetc, "read next char from file",
  209. X    "fgetline", 1, 1, 0, OP_NOP, 0, f_fgetline, "read next line from file",
  210. X    "files", 0, 1, 0, OP_NOP, 0, f_files, "return opened file or max number of opened files",
  211. X    "floor", 1, 1, 0, OP_NOP, f_floor, 0, "greatest integer less than or equal to number",
  212. X    "fopen", 2, 2, 0, OP_NOP, 0, f_fopen, "open file name a in mode b",
  213. X    "fprintf", 2, IN, 0, OP_NOP, 0, f_fprintf, "print formatted output to opened file",
  214. X    "frac", 1, 1, 0, OP_FRAC, qfrac, 0, "fractional part of value",
  215. X    "gcd", 1,IN, 0, OP_NOP, f_gcd, 0, "greatest common divisor",
  216. X    "gcdrem", 2, 2, 0, OP_NOP, qgcdrem, 0, "a divided repeatedly by gcd with b",
  217. X    "highbit", 1, 1, 0, OP_NOP, f_highbit, 0, "high bit number in base 2 representation",
  218. X    "hmean", 1,IN, 0, OP_NOP, f_hmean, 0, "harmonic mean of values",
  219. X    "hypot", 2, 3, FE, OP_NOP, qhypot, 0, "hypotenuse of right triangle within accuracy c",
  220. X    "ilog", 2, 2, 0, OP_NOP, f_ilog, 0, "integral log of one number with another",
  221. X    "ilog10", 1, 1, 0, OP_NOP, f_ilog10, 0, "integral log of a number base 10",
  222. X    "ilog2", 1, 1, 0, OP_NOP, f_ilog2, 0, "integral log of a number base 2",
  223. X    "im", 1, 1, 0, OP_IM, 0, 0, "imaginary part of complex number",
  224. X    "insert", 3, 3, FA, OP_NOP, 0, f_listinsert, "insert value c into list a at position b",
  225. X     "int", 1, 1, 0, OP_INT, qint, 0, "integer part of value",
  226. X    "inverse", 1, 1, 0, OP_INVERT, 0, 0, "multiplicative inverse of value",
  227. X    "iroot", 2, 2, 0, OP_NOP, qiroot, 0, "integer b'th root of a",
  228. X    "iseven", 1, 1, 0, OP_ISEVEN, 0, 0, "whether a value is an even integer",
  229. X    "isfile", 1, 1, 0, OP_ISFILE, 0, 0, "whether a value is a file",
  230. X    "isint", 1, 1, 0, OP_ISINT, 0, 0, "whether a value is an integer",
  231. X    "islist", 1, 1, 0, OP_ISLIST, 0, 0, "whether a value is a list",
  232. X    "ismat", 1, 1, 0, OP_ISMAT, 0, 0, "whether a value is a matrix",
  233. X    "ismult", 2, 2, 0, OP_NOP, f_ismult, 0, "whether a is a multiple of b",
  234. X    "isnull", 1, 1, 0, OP_ISNULL, 0, 0, "whether a value is the null value",
  235. X    "isnum", 1, 1, 0, OP_ISNUM, 0, 0, "whether a value is a number",
  236. X    "isobj", 1, 1, 0, OP_ISOBJ, 0, 0, "whether a value is an object",
  237. X    "isodd", 1, 1, 0, OP_ISODD, 0, 0, "whether a value is an odd integer",
  238. X    "isqrt", 1, 1, 0, OP_NOP, qisqrt, 0, "integer part of square root",
  239. X    "isreal", 1, 1, 0, OP_ISREAL, 0, 0, "whether a value is a real number",
  240. X    "isset", 2, 2, 0, OP_NOP, f_isset, 0, "whether bit b of abs(a) (in base 2) is set",
  241. X    "isstr", 1, 1, 0, OP_ISSTR, 0, 0, "whether a value is a string",
  242. X    "isrel", 2, 2, 0, OP_NOP, f_isrel, 0, "whether two numbers are relatively prime",
  243. X    "issimple", 1, 1, 0, OP_ISSIMPLE, 0, 0, "whether value is a simple type",
  244. X    "issq", 1, 1, 0, OP_NOP, f_issquare, 0, "whether or not number is a square",
  245. X     "istype", 2, 2, 0, OP_ISTYPE, 0, 0, "whether the type of a is same as the type of b",
  246. X    "jacobi", 2, 2, 0, OP_NOP, qjacobi, 0, "-1 => a is not quadratic residue mod b\n\t\t 1 => b is composite, or a is quad residue of b",
  247. X    "lcm", 1, IN, 0, OP_NOP, f_lcm, 0, "least common multiple",
  248. X    "lcmfact", 1, 1, 0, OP_NOP, qlcmfact, 0, "lcm of all integers up till number",
  249. X    "lfactor", 2, 2, 0, OP_NOP, qlowfactor, 0, "lowest prime factor of a in first b primes",
  250. X    "list", 0, IN, 0, OP_NOP, 0, f_list, "create list of specified values",
  251. X    "ln", 1, 2, 0, OP_NOP, 0, f_ln, "natural logarithm of value a within accuracy b",
  252. X    "lowbit", 1, 1, 0, OP_NOP, f_lowbit, 0, "low bit number in base 2 representation",
  253. X    "ltol", 1, 2, FE, OP_NOP, f_legtoleg, 0, "leg-to-leg of unit right triangle (sqrt(1 - a^2))",
  254. X    "matdim", 1, 1, 0, OP_NOP, 0, f_matdim, "number of dimensions of matrix",
  255. X    "matfill", 2, 3, FA, OP_NOP, 0, f_matfill, "fill matrix with value b (value c on diagonal)",
  256. X    "matmax", 2, 2, 0, OP_NOP, 0, f_matmax, "maximum index of matrix a dim b",
  257. X    "matmin", 2, 2, 0, OP_NOP, 0, f_matmin, "minimum index of matrix a dim b",
  258. X    "mattrans", 1, 1, 0, OP_NOP, 0, f_mattrans, "transpose of matrix",
  259. X    "max", 1, IN, 0, OP_NOP, f_max, 0, "maximum value",
  260. X    "meq", 3, 3, 0, OP_NOP, f_meq, 0, "whether a and b are equal modulo c",
  261. X    "min", 1, IN, 0, OP_NOP, f_min, 0, "minimum value",
  262. X    "minv", 2, 2, 0, OP_NOP, qminv, 0, "inverse of a modulo b",
  263. X    "mmin", 2, 2, 0, OP_NOP, qminmod, 0, "a mod b value with smallest abs value",
  264. X    "mne", 3, 3, 0, OP_NOP, f_mne, 0, "whether a and b are not equal modulo c",
  265. X    "near", 2, 3, 0, OP_NOP, f_near, 0, "sign of (abs(a-b) - c)",
  266. X    "norm", 1, 1, 0, OP_NORM, 0, 0, "norm of a value (square of absolute value)",
  267. X    "null", 0, 0, 0, OP_UNDEF, 0, 0, "null value",
  268. X    "num", 1, 1, 0, OP_NUMERATOR, qnum, 0, "numerator of fraction",
  269. X    "ord", 1, 1, 0, OP_NOP, 0, f_ord, "integer corresponding to character value",
  270. X    "param", 1, 1, 0, OP_ARGVALUE, 0, 0, "value of parameter n (or parameter count if n is zero)",
  271. X    "perm", 2, 2, 0, OP_NOP, qperm, 0, "permutation number a!/(a-b)!",
  272. X    "pfact", 1, 1, 0, OP_NOP, qpfact, 0, "product of primes up till number",
  273. X    "pi", 0, 1, FE, OP_NOP, qpi, 0, "value of pi accurate to within epsilon",
  274. X    "places", 1, 1, 0, OP_NOP, f_places, 0, "places after decimal point (-1 if infinite)",
  275. X    "pmod", 3, 3, 0, OP_NOP, qpowermod,0, "mod of a power (a ^ b (mod c))",
  276. X    "polar", 2, 3, 0, OP_NOP, 0, f_polar, "complex value of polar coordinate (a * exp(b*1i))",
  277. X    "poly", 2, IN, 0, OP_NOP, 0, f_poly, "(a1,a2,...,an,x) = a1*x^n+a2*x^(n-1)+...+an",
  278. X    "pop", 1, 1, FA, OP_NOP, 0, f_listpop, "pop value from front of list",
  279. X    "power", 2, 3, 0, OP_NOP, 0, f_power, "value a raised to the power b within accuracy c",
  280. X    "ptest", 2, 2, 0, OP_NOP, f_primetest, 0, "probabilistic primality test",
  281. X    "printf", 1, IN, 0, OP_NOP, 0, f_printf, "print formatted output to stdout",
  282. X    "prompt", 1, 1, 0, OP_NOP, 0, f_prompt, "prompt for input line using value a",
  283. X    "push", 2, 2, FA, OP_NOP, 0, f_listpush, "push value onto front of list",
  284. X    "quomod", 4, 4, 0, OP_QUOMOD, 0, 0, "set c and d to quotient and remainder of a divided by b",
  285. X    "rcin", 2, 2, 0, OP_NOP, qredcin, 0, "convert normal number a to REDC number mod b",
  286. X    "rcmul", 3, 3, 0, OP_NOP, qredcmul, 0, "multiply REDC numbers a and b mod c",
  287. X    "rcout", 2, 2, 0, OP_NOP, qredcout, 0, "convert REDC number a mod b to normal number",
  288. X    "rcpow", 3, 3, 0, OP_NOP, qredcpower, 0, "raise REDC number a to power b mod c",
  289. X    "rcsq", 2, 2, 0, OP_NOP, qredcsquare, 0, "square REDC number a mod b",
  290. X    "re", 1, 1, 0, OP_RE, 0, 0, "real part of complex number",
  291. X    "remove", 1, 1, FA, OP_NOP, 0, f_listremove, "remove value from end of list",
  292. X    "root", 2, 3, 0, OP_NOP, 0, f_root, "value a taken to the b'th root within accuracy c",
  293. X    "round", 1, 2, 0, OP_NOP, 0, f_round, "round value a to b number of decimal places",
  294. X    "rsearch", 2, 3, 0, OP_NOP, 0, f_rsearch, "reverse search matrix or list for value b starting at index c",
  295. X    "runtime", 0, 0, 0, OP_NOP, f_runtime, 0, "user mode cpu time in seconds",
  296. X    "scale", 2, 2, 0, OP_SCALE, 0, 0, "scale value up or down by a power of two",
  297. X    "search", 2, 3, 0, OP_NOP, 0, f_search, "search matrix or list for value b starting at index c",
  298. X    "sgn", 1, 1, 0, OP_SGN, qsign, 0, "sign of value (-1, 0, 1)",
  299. X    "sin", 1, 2, 0, OP_NOP, 0, f_sin, "sine of value a within accuracy b",
  300. X    "sinh", 1, 2, FE, OP_NOP, qsinh, 0, "hyperbolic sine of a within accuracy b",
  301. X    "size", 1, 1, 0, OP_NOP, 0, f_size, "total number of elements in value",
  302. X    "sqrt", 1, 2, 0, OP_NOP, 0, f_sqrt, "square root of value a within accuracy b",
  303. X    "ssq", 1, IN, 0, OP_NOP, 0, f_ssq, "sum of squares of values",
  304. X    "str", 1, 1, 0, OP_NOP, 0, f_str, "simple value converted to string",
  305. X    "strcat", 1,IN, 0, OP_NOP, 0, f_strcat, "concatenate strings together",
  306. X    "strlen", 1, 1, 0, OP_NOP, 0, f_strlen, "length of string",
  307. X    "strprintf", 1, IN, 0, OP_NOP, 0, f_strprintf, "return formatted output as a string",
  308. X    "substr", 3, 3, 0, OP_NOP, 0, f_substr, "substring of a from position b for c chars",
  309. X    "swap", 2, 2, 0, OP_SWAP, 0, 0, "swap values of variables a and b (can be dangerous)",
  310. X    "tan", 1, 2, FE, OP_NOP, qtan, 0, "tangent of a within accuracy b",
  311. X    "tanh", 1, 2, FE, OP_NOP, qtanh, 0, "hyperbolic tangent of a within accuracy b",
  312. X    "trunc", 1, 2, 0, OP_NOP, f_trunc, 0, "truncate a to b number of decimal places",
  313. X    "xor", 1, IN, 0, OP_NOP, f_xor, 0, "logical xor",
  314. X    NULL, 0, 0, 0, OP_NOP, 0, 0, NULL /* end of table */
  315. X};
  316. X
  317. X
  318. X/*
  319. X * Call a built-in function.
  320. X * Arguments to the function are on the stack, but are not removed here.
  321. X * Functions are either purely numeric, or else can take any value type.
  322. X */
  323. XVALUE
  324. Xbuiltinfunc(index, argcount, stack)
  325. X    long index;
  326. X    VALUE *stack;        /* arguments on the stack */
  327. X{
  328. X    VALUE *sp;        /* pointer to stack entries */
  329. X    VALUE **vpp;        /* pointer to current value address */
  330. X    struct builtin *bp;    /* builtin function to be called */
  331. X    long i;            /* index */
  332. X    NUMBER *numargs[IN];    /* numeric arguments for function */
  333. X    VALUE *valargs[IN];    /* addresses of actual arguments */
  334. X    VALUE result;        /* general result of function */
  335. X
  336. X    if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1)
  337. X        error("Bad built-in function index");
  338. X    bp = &builtins[index];
  339. X    if (argcount < bp->b_minargs)
  340. X        error("Too few arguments for builtin function \"%s\"", bp->b_name);
  341. X    if ((argcount > bp->b_maxargs) || (argcount > IN))
  342. X        error("Too many arguments for builtin function \"%s\"", bp->b_name);
  343. X    /*
  344. X     * If an address was passed, then point at the real variable,
  345. X     * otherwise point at the stack value itself (unless the function
  346. X     * is very special).
  347. X     */
  348. X    sp = stack - argcount + 1;
  349. X    vpp = valargs;
  350. X    for (i = argcount; i > 0; i--) {
  351. X        if ((sp->v_type != V_ADDR) || (bp->b_flags & FA))
  352. X            *vpp = sp;
  353. X        else
  354. X            *vpp = sp->v_addr;
  355. X        sp++;
  356. X        vpp++;
  357. X    }
  358. X    /*
  359. X     * Handle general values if the function accepts them.
  360. X     */
  361. X    if (bp->b_valfunc) {
  362. X        vpp = valargs;
  363. X        if ((bp->b_minargs == 1) && (bp->b_maxargs == 1))
  364. X            result = (*bp->b_valfunc)(vpp[0]);
  365. X        else if ((bp->b_minargs == 2) && (bp->b_maxargs == 2))
  366. X            result = (*bp->b_valfunc)(vpp[0], vpp[1]);
  367. X        else if ((bp->b_minargs == 3) && (bp->b_maxargs == 3))
  368. X            result = (*bp->b_valfunc)(vpp[0], vpp[1], vpp[2]);
  369. X        else
  370. X            result = (*bp->b_valfunc)(argcount, vpp);
  371. X        return result;
  372. X    }
  373. X    /*
  374. X     * Function must be purely numeric, so handle that.
  375. X     */
  376. X    vpp = valargs;
  377. X    for (i = 0; i < argcount; i++) {
  378. X        if ((*vpp)->v_type != V_NUM)
  379. X            error("Non-real argument for builtin function %s", bp->b_name);
  380. X        numargs[i] = (*vpp)->v_num;
  381. X        vpp++;
  382. X    }
  383. X    result.v_type = V_NUM;
  384. X    if (!(bp->b_flags & FE) && (bp->b_minargs != bp->b_maxargs)) {
  385. X        result.v_num = (*bp->b_numfunc)(argcount, numargs);
  386. X        return result;
  387. X    }
  388. X    if ((bp->b_flags & FE) && (argcount < bp->b_maxargs))
  389. X        numargs[argcount++] = _epsilon_;
  390. X
  391. X    switch (argcount) {
  392. X        case 0:
  393. X            result.v_num = (*bp->b_numfunc)();
  394. X            break;
  395. X        case 1:
  396. X            result.v_num = (*bp->b_numfunc)(numargs[0]);
  397. X            break;
  398. X        case 2:
  399. X            result.v_num = (*bp->b_numfunc)(numargs[0], numargs[1]);
  400. X            break;
  401. X        case 3:
  402. X            result.v_num = (*bp->b_numfunc)(numargs[0], numargs[1], numargs[2]);
  403. X            break;
  404. X        default:
  405. X            error("Bad builtin function call");
  406. X    }
  407. X    return result;
  408. X}
  409. X
  410. X
  411. Xstatic VALUE
  412. Xf_eval(vp)
  413. X    VALUE *vp;
  414. X{
  415. X    FUNC    *oldfunc;
  416. X    FUNC    *newfunc;
  417. X    VALUE    result;
  418. X
  419. X    if (vp->v_type != V_STR)
  420. X        error("Evaluating non-string argument");
  421. X    (void) openstring(vp->v_str);
  422. X    oldfunc = curfunc;
  423. X    if (evaluate(TRUE)) {
  424. X        freevalue(stack--);
  425. X        newfunc = curfunc;
  426. X        curfunc = oldfunc;
  427. X        result = newfunc->f_savedvalue;
  428. X        newfunc->f_savedvalue.v_type = V_NULL;
  429. X        if (newfunc != oldfunc)
  430. X            free(newfunc);
  431. X        return result;
  432. X    }
  433. X    newfunc = curfunc;
  434. X    curfunc = oldfunc;
  435. X    freevalue(&newfunc->f_savedvalue);
  436. X    newfunc->f_savedvalue.v_type = V_NULL;
  437. X    if (newfunc != oldfunc)
  438. X        free(newfunc);
  439. X    error("Evaluation error");
  440. X    /*NOTREACHED*/
  441. X}
  442. X
  443. X
  444. Xstatic VALUE
  445. Xf_prompt(vp)
  446. X    VALUE *vp;
  447. X{
  448. X    VALUE result;
  449. X    char *cp;
  450. X    char *newcp;
  451. X
  452. X    if (inputisterminal()) {
  453. X        printvalue(vp, PRINT_SHORT);
  454. X        math_flush();
  455. X    }
  456. X    cp = nextline();
  457. X    if (cp == NULL)
  458. X        error("End of file while prompting");
  459. X    if (*cp == '\0') {
  460. X        result.v_type = V_STR;
  461. X        result.v_subtype = V_STRLITERAL;
  462. X        result.v_str = "";
  463. X        return result;
  464. X    }
  465. X    newcp = (char *)malloc(strlen(cp) + 1);
  466. X    if (newcp == NULL)
  467. X        error("Cannot allocate string");
  468. X    strcpy(newcp, cp);
  469. X    result.v_str = newcp;
  470. X    result.v_type = V_STR;
  471. X    result.v_subtype = V_STRALLOC;
  472. X    return result;
  473. X}
  474. X
  475. X
  476. Xstatic VALUE
  477. Xf_str(vp)
  478. X    VALUE *vp;
  479. X{
  480. X    VALUE result;
  481. X    char *cp;
  482. X
  483. X    switch (vp->v_type) {
  484. X        case V_STR:
  485. X            copyvalue(vp, &result);
  486. X            return result;
  487. X        case V_NULL:
  488. X            result.v_str = "";
  489. X            result.v_type = V_STR;
  490. X            result.v_subtype = V_STRLITERAL;
  491. X            return result;
  492. X        case V_NUM:
  493. X            divertio();
  494. X            qprintnum(vp->v_num, MODE_DEFAULT);
  495. X            cp = getdivertedio();
  496. X            break;
  497. X        case V_COM:
  498. X            divertio();
  499. X            comprint(vp->v_com);
  500. X            cp = getdivertedio();
  501. X            break;
  502. X        default:
  503. X            error("Non-simple type for string conversion");
  504. X    }
  505. X    result.v_str = cp;
  506. X    result.v_type = V_STR;
  507. X    result.v_subtype = V_STRALLOC;
  508. X    return result;
  509. X}
  510. X
  511. X
  512. Xstatic VALUE
  513. Xf_poly(count, vals)
  514. X    VALUE **vals;
  515. X{
  516. X    VALUE *x;
  517. X    VALUE result, tmp;
  518. X
  519. X    x = vals[--count];
  520. X    copyvalue(*vals++, &result);
  521. X    while (--count > 0) {
  522. X        mulvalue(&result, x, &tmp);
  523. X        freevalue(&result);
  524. X        addvalue(*vals++, &tmp, &result);
  525. X        freevalue(&tmp);
  526. X    }
  527. X    return result;
  528. X}
  529. X
  530. X
  531. Xstatic NUMBER *
  532. Xf_mne(val1, val2, val3)
  533. X    NUMBER *val1, *val2, *val3;
  534. X{
  535. X    return itoq((long) qcmpmod(val1, val2, val3));
  536. X}
  537. X
  538. X
  539. Xstatic NUMBER *
  540. Xf_isrel(val1, val2)
  541. X    NUMBER *val1, *val2;
  542. X{
  543. X    if (qisfrac(val1) || qisfrac(val2))
  544. X        error("Non-integer for isrel");
  545. X    return itoq((long) zrelprime(val1->num, val2->num));
  546. X}
  547. X
  548. X
  549. Xstatic NUMBER *
  550. Xf_issquare(vp)
  551. X    NUMBER *vp;
  552. X{
  553. X    return itoq((long) qissquare(vp));
  554. X}
  555. X
  556. X
  557. Xstatic NUMBER *
  558. Xf_primetest(val1, val2)
  559. X    NUMBER *val1, *val2;
  560. X{
  561. X    return itoq((long) qprimetest(val1, val2));
  562. X}
  563. X
  564. X
  565. Xstatic NUMBER *
  566. Xf_isset(val1, val2)
  567. X    NUMBER *val1, *val2;
  568. X{
  569. X    if (qisfrac(val2))
  570. X        error("Non-integral bit position");
  571. X    if (qiszero(val1) || (qisint(val1) && qisneg(val2)))
  572. X        return qlink(&_qzero_);
  573. X    if (isbig(val2->num)) {
  574. X        if (qisneg(val2))
  575. X            error("Very large bit position");
  576. X        return qlink(&_qzero_);
  577. X    }
  578. X    return itoq((long) qisset(val1, qtoi(val2)));
  579. X}
  580. X
  581. X
  582. Xstatic NUMBER *
  583. Xf_digit(val1, val2)
  584. X    NUMBER *val1, *val2;
  585. X{
  586. X    if (qisfrac(val2))
  587. X        error("Non-integral digit position");
  588. X    if (qiszero(val1) || (qisint(val1) && qisneg(val2)))
  589. X        return qlink(&_qzero_);
  590. X    if (isbig(val2->num)) {
  591. X        if (qisneg(val2))
  592. X            error("Very large digit position");
  593. X        return qlink(&_qzero_);
  594. X    }
  595. X    return itoq((long) qdigit(val1, qtoi(val2)));
  596. X}
  597. X
  598. X
  599. Xstatic NUMBER *
  600. Xf_digits(val)
  601. X    NUMBER *val;
  602. X{
  603. X    return itoq((long) qdigits(val));
  604. X}
  605. X
  606. X
  607. Xstatic NUMBER *
  608. Xf_places(val)
  609. X    NUMBER *val;
  610. X{
  611. X    return itoq((long) qplaces(val));
  612. X}
  613. X
  614. X
  615. Xstatic NUMBER *
  616. Xf_xor(count, vals)
  617. X    NUMBER **vals;
  618. X{
  619. X    NUMBER *val, *tmp;
  620. X
  621. X    val = qlink(*vals);
  622. X    while (--count > 0) {
  623. X        tmp = qxor(val, *++vals);
  624. X        qfree(val);
  625. X        val = tmp;
  626. X    }
  627. X    return val;
  628. X}
  629. X
  630. X
  631. Xstatic NUMBER *
  632. Xf_min(count, vals)
  633. X    NUMBER **vals;
  634. X{
  635. X    NUMBER *val, *tmp;
  636. X
  637. X    val = qlink(*vals);
  638. X    while (--count > 0) {
  639. X        tmp = qmin(val, *++vals);
  640. X        qfree(val);
  641. X        val = tmp;
  642. X    }
  643. X    return val;
  644. X}
  645. X
  646. X
  647. Xstatic NUMBER *
  648. Xf_max(count, vals)
  649. X    NUMBER **vals;
  650. X{
  651. X    NUMBER *val, *tmp;
  652. X
  653. X    val = qlink(*vals);
  654. X    while (--count > 0) {
  655. X        tmp = qmax(val, *++vals);
  656. X        qfree(val);
  657. X        val = tmp;
  658. X    }
  659. X    return val;
  660. X}
  661. X
  662. X
  663. Xstatic NUMBER *
  664. Xf_gcd(count, vals)
  665. X    NUMBER **vals;
  666. X{
  667. X    NUMBER *val, *tmp;
  668. X
  669. X    val = qlink(*vals);
  670. X    while (--count > 0) {
  671. X        tmp = qgcd(val, *++vals);
  672. X        qfree(val);
  673. X        val = tmp;
  674. X        if (qisunit(val))
  675. X            break;
  676. X    }
  677. X    return val;
  678. X}
  679. X
  680. X
  681. Xstatic NUMBER *
  682. Xf_lcm(count, vals)
  683. X    NUMBER **vals;
  684. X{
  685. X    NUMBER *val, *tmp;
  686. X
  687. X    val = qlink(*vals);
  688. X    while (--count > 0) {
  689. X        tmp = qlcm(val, *++vals);
  690. X        qfree(val);
  691. X        val = tmp;
  692. X    }
  693. X    return val;
  694. X}
  695. X
  696. X
  697. Xstatic VALUE
  698. Xf_avg(count, vals)
  699. X    VALUE **vals;
  700. X{
  701. X    int i;
  702. X    VALUE result;
  703. X    VALUE tmp;
  704. X    VALUE div;
  705. X
  706. X    result.v_num = qlink(&_qzero_);
  707. X    result.v_type = V_NUM;
  708. X    for (i = count; i > 0; i--) {
  709. X        addvalue(&result, *vals++, &tmp);
  710. X        freevalue(&result);
  711. X        result = tmp;
  712. X    }
  713. X    if (count <= 1)
  714. X        return result;
  715. X    div.v_num = itoq((long) count);
  716. X    div.v_type = V_NUM;
  717. X    divvalue(&result, &div, &tmp);
  718. X    qfree(div.v_num);
  719. X    return tmp;
  720. X}
  721. X
  722. X
  723. Xstatic NUMBER *
  724. Xf_hmean(count, vals)
  725. X    NUMBER **vals;
  726. X{
  727. X    NUMBER *val, *tmp, *tmp2;
  728. X
  729. X    val = qinv(*vals);
  730. X    while (--count > 0) {
  731. X        tmp2 = qinv(*++vals);
  732. X        tmp = qadd(val, tmp2);
  733. X        qfree(tmp2);
  734. X        qfree(val);
  735. X        val = tmp;
  736. X    }
  737. X    tmp = qinv(val);
  738. X    qfree(val);
  739. X    return tmp;
  740. X}
  741. X
  742. X
  743. Xstatic VALUE
  744. Xf_ssq(count, vals)
  745. X    VALUE **vals;
  746. X{
  747. X    VALUE result, tmp1, tmp2;
  748. X
  749. X    squarevalue(*vals++, &result);
  750. X    while (--count > 0) {
  751. X        squarevalue(*vals++, &tmp1);
  752. X        addvalue(&tmp1, &result, &tmp2);
  753. X        freevalue(&tmp1);
  754. X        freevalue(&result);
  755. X        result = tmp2;
  756. X    }
  757. X    return result;
  758. X}
  759. X
  760. X
  761. Xstatic NUMBER *
  762. Xf_ismult(val1, val2)
  763. X    NUMBER *val1, *val2;
  764. X{
  765. X    return itoq((long) qdivides(val1, val2));
  766. X}
  767. X
  768. X
  769. Xstatic NUMBER *
  770. Xf_meq(val1, val2, val3)
  771. X    NUMBER *val1, *val2, *val3;
  772. X{
  773. X    NUMBER *tmp, *res;
  774. X
  775. X    tmp = qsub(val1, val2);
  776. X    res = itoq((long) qdivides(tmp, val3));
  777. X    qfree(tmp);
  778. X    return res;
  779. X}
  780. X
  781. X
  782. Xstatic VALUE
  783. Xf_exp(count, vals)
  784. X    VALUE **vals;
  785. X{
  786. X    VALUE result;
  787. X    NUMBER *err;
  788. X
  789. X    err = _epsilon_;
  790. X    if (count == 2) {
  791. X        if (vals[1]->v_type != V_NUM)
  792. X            error("Non-real epsilon value for exp");
  793. X        err = vals[1]->v_num;
  794. X    }
  795. X    switch (vals[0]->v_type) {
  796. X        case V_NUM:
  797. X            result.v_num = qexp(vals[0]->v_num, err);
  798. X            result.v_type = V_NUM;
  799. X            break;
  800. X        case V_COM:
  801. X            result.v_com = cexp(vals[0]->v_com, err);
  802. X            result.v_type = V_COM;
  803. X            break;
  804. X        default:
  805. X            error("Bad argument type for exp");
  806. X    }
  807. X    return result;
  808. X}
  809. X
  810. X
  811. Xstatic VALUE
  812. Xf_ln(count, vals)
  813. X    VALUE **vals;
  814. X{
  815. X    VALUE result;
  816. X    COMPLEX temp;
  817. X    NUMBER *err;
  818. X
  819. X    err = _epsilon_;
  820. X    if (count == 2) {
  821. X        if (vals[1]->v_type != V_NUM)
  822. X            error("Non-real epsilon value for ln");
  823. X        err = vals[1]->v_num;
  824. X    }
  825. X    switch (vals[0]->v_type) {
  826. X        case V_NUM:
  827. X            if (!qisneg(vals[0]->v_num) && !qiszero(vals[0]->v_num)) {
  828. X                result.v_num = qln(vals[0]->v_num, err);
  829. X                result.v_type = V_NUM;
  830. X                break;
  831. X            }
  832. X            temp.real = vals[0]->v_num;
  833. X            temp.imag = &_qzero_;
  834. X            result.v_com = cln(&temp, err);
  835. X            result.v_type = V_COM;
  836. X            break;
  837. X        case V_COM:
  838. X            result.v_com = cln(vals[0]->v_com, err);
  839. X            result.v_type = V_COM;
  840. X            break;
  841. X        default:
  842. X            error("Bad argument type for ln");
  843. X    }
  844. X    return result;
  845. X}
  846. X
  847. X
  848. Xstatic VALUE
  849. Xf_cos(count, vals)
  850. X    VALUE **vals;
  851. X{
  852. X    VALUE result;
  853. X    COMPLEX *c;
  854. X    NUMBER *err;
  855. X
  856. X    err = _epsilon_;
  857. X    if (count == 2) {
  858. X        if (vals[1]->v_type != V_NUM)
  859. X            error("Non-real epsilon value for cos");
  860. X        err = vals[1]->v_num;
  861. X    }
  862. X    switch (vals[0]->v_type) {
  863. X        case V_NUM:
  864. X            result.v_num = qcos(vals[0]->v_num, err);
  865. X            result.v_type = V_NUM;
  866. X            break;
  867. X        case V_COM:
  868. X            c = ccos(vals[0]->v_com, err);
  869. X            result.v_com = c;
  870. X            result.v_type = V_COM;
  871. X            if (cisreal(c)) {
  872. X                result.v_num = qlink(c->real);
  873. X                result.v_type = V_NUM;
  874. X                comfree(c);
  875. X            }
  876. X            break;
  877. X        default:
  878. X            error("Bad argument type for cos");
  879. X    }
  880. X    return result;
  881. X}
  882. X
  883. X
  884. Xstatic VALUE
  885. Xf_sin(count, vals)
  886. X    VALUE **vals;
  887. X{
  888. X    VALUE result;
  889. X    COMPLEX *c;
  890. X    NUMBER *err;
  891. X
  892. X    err = _epsilon_;
  893. X    if (count == 2) {
  894. X        if (vals[1]->v_type != V_NUM)
  895. X            error("Non-real epsilon value for sin");
  896. X        err = vals[1]->v_num;
  897. X    }
  898. X    switch (vals[0]->v_type) {
  899. X        case V_NUM:
  900. X            result.v_num = qsin(vals[0]->v_num, err);
  901. X            result.v_type = V_NUM;
  902. X            break;
  903. X        case V_COM:
  904. X            c = csin(vals[0]->v_com, err);
  905. X            result.v_com = c;
  906. X            result.v_type = V_COM;
  907. X            if (cisreal(c)) {
  908. X                result.v_num = qlink(c->real);
  909. X                result.v_type = V_NUM;
  910. X                comfree(c);
  911. X            }
  912. X            break;
  913. X        default:
  914. X            error("Bad argument type for sin");
  915. X    }
  916. X    return result;
  917. X}
  918. X
  919. X
  920. Xstatic VALUE
  921. Xf_arg(count, vals)
  922. X    VALUE **vals;
  923. X{
  924. X    VALUE result;
  925. X    COMPLEX *c;
  926. X    NUMBER *err;
  927. X
  928. X    err = _epsilon_;
  929. X    if (count == 2) {
  930. X        if (vals[1]->v_type != V_NUM)
  931. X            error("Non-real epsilon value for arg");
  932. X        err = vals[1]->v_num;
  933. X    }
  934. X    result.v_type = V_NUM;
  935. X    switch (vals[0]->v_type) {
  936. X        case V_NUM:
  937. X            if (qisneg(vals[0]->v_num))
  938. X                result.v_num = qpi(err);
  939. X            else
  940. X                result.v_num = qlink(&_qzero_);
  941. X            break;
  942. X        case V_COM:
  943. X            c = vals[0]->v_com;
  944. X            if (ciszero(c))
  945. X                result.v_num = qlink(&_qzero_);
  946. X            else
  947. X                result.v_num = qatan2(c->imag, c->real, err);
  948. X            break;
  949. X        default:
  950. X            error("Bad argument type for arg");
  951. X    }
  952. X    return result;
  953. X}
  954. X
  955. X
  956. Xstatic NUMBER *
  957. Xf_legtoleg(val1, val2)
  958. X    NUMBER *val1, *val2;
  959. X{
  960. X    return qlegtoleg(val1, val2, FALSE);
  961. X}
  962. X
  963. X
  964. Xstatic NUMBER *
  965. Xf_trunc(count, vals)
  966. X    NUMBER **vals;
  967. X{
  968. X    NUMBER *val;
  969. X
  970. X    val = &_qzero_;
  971. X    if (count == 2)
  972. X        val = vals[1];
  973. X    return qtrunc(*vals, val);
  974. X}
  975. X
  976. X
  977. Xstatic VALUE
  978. Xf_bround(count, vals)
  979. X    VALUE **vals;
  980. X{
  981. X    VALUE *vp, tmp, res;
  982. X
  983. X    if (count > 1)
  984. X        vp = vals[1];
  985. X    else {
  986. X        tmp.v_type = V_INT;
  987. X        tmp.v_num = 0;
  988. X        vp = &tmp;
  989. X    }
  990. X    broundvalue(vals[0], vp, &res);
  991. X    return res;
  992. X}
  993. X
  994. X
  995. Xstatic VALUE
  996. Xf_round(count, vals)
  997. X    VALUE **vals;
  998. X{
  999. X    VALUE *vp, tmp, res;
  1000. X
  1001. X    if (count > 1)
  1002. X        vp = vals[1];
  1003. X    else {
  1004. X        tmp.v_type = V_INT;
  1005. X        tmp.v_num = 0;
  1006. X        vp = &tmp;
  1007. X    }
  1008. X    roundvalue(vals[0], vp, &res);
  1009. X    return res;
  1010. X}
  1011. X
  1012. X
  1013. Xstatic NUMBER *
  1014. Xf_btrunc(count, vals)
  1015. X    NUMBER **vals;
  1016. X{
  1017. X    NUMBER *val;
  1018. X
  1019. X    val = &_qzero_;
  1020. X    if (count == 2)
  1021. X        val = vals[1];
  1022. X    return qbtrunc(*vals, val);
  1023. X}
  1024. X
  1025. X
  1026. Xstatic NUMBER *
  1027. Xf_near(count, vals)
  1028. X    NUMBER **vals;
  1029. X{
  1030. X    NUMBER *val;
  1031. X
  1032. X    val = _epsilon_;
  1033. X    if (count == 3)
  1034. X        val = vals[2];
  1035. X    return itoq((long) qnear(vals[0], vals[1], val));
  1036. X}
  1037. X
  1038. X
  1039. Xstatic NUMBER *
  1040. Xf_cfsim(val)
  1041. X    NUMBER *val;
  1042. X{
  1043. X    return qcfappr(val, NULL);
  1044. X}
  1045. X
  1046. X
  1047. Xstatic NUMBER *
  1048. Xf_ceil(val)
  1049. X    NUMBER *val;
  1050. X{
  1051. X    NUMBER *val2;
  1052. X
  1053. X    if (qisint(val))
  1054. X        return qlink(val);
  1055. X    val2 = qint(val);
  1056. X    if (qisneg(val2))
  1057. X        return val2;
  1058. X    val = qinc(val2);
  1059. X    qfree(val2);
  1060. X    return val;
  1061. X}
  1062. X
  1063. X
  1064. Xstatic NUMBER *
  1065. Xf_floor(val)
  1066. X    NUMBER *val;
  1067. X{
  1068. X    NUMBER *val2;
  1069. X
  1070. X    if (qisint(val))
  1071. X        return qlink(val);
  1072. X    val2 = qint(val);
  1073. X    if (!qisneg(val2))
  1074. X        return val2;
  1075. X    val = qdec(val2);
  1076. X    qfree(val2);
  1077. X    return val;
  1078. X}
  1079. X
  1080. X
  1081. Xstatic NUMBER *
  1082. Xf_highbit(val)
  1083. X    NUMBER *val;
  1084. X{
  1085. X    if (qiszero(val))
  1086. X        error("Highbit of zero");
  1087. X    if (qisfrac(val))
  1088. X        error("Highbit of non-integer");
  1089. X    return itoq(zhighbit(val->num));
  1090. X}
  1091. X
  1092. X
  1093. Xstatic NUMBER *
  1094. Xf_lowbit(val)
  1095. X    NUMBER *val;
  1096. X{
  1097. X    if (qiszero(val))
  1098. X        error("Lowbit of zero");
  1099. X    if (qisfrac(val))
  1100. X        error("Lowbit of non-integer");
  1101. X    return itoq(zlowbit(val->num));
  1102. X}
  1103. X
  1104. X
  1105. Xstatic VALUE
  1106. Xf_sqrt(count, vals)
  1107. X    VALUE **vals;
  1108. X{
  1109. X    VALUE *vp, err, result;
  1110. X
  1111. X    if (count > 1)
  1112. X        vp = vals[1];
  1113. X    else {
  1114. X        err.v_num = _epsilon_;
  1115. X        err.v_type = V_NUM;
  1116. X        vp = &err;
  1117. X    }
  1118. X    sqrtvalue(vals[0], vp, &result);
  1119. X    return result;
  1120. X}
  1121. X
  1122. X
  1123. Xstatic VALUE
  1124. Xf_root(count, vals)
  1125. X    VALUE **vals;
  1126. X{
  1127. X    VALUE *vp, err, result;
  1128. X
  1129. X    if (count > 2)
  1130. X        vp = vals[3];
  1131. X    else {
  1132. X        err.v_num = _epsilon_;
  1133. X        err.v_type = V_NUM;
  1134. X        vp = &err;
  1135. X    }
  1136. X    rootvalue(vals[0], vals[1], vp, &result);
  1137. X    return result;
  1138. X}
  1139. X
  1140. X
  1141. Xstatic VALUE
  1142. Xf_power(count, vals)
  1143. X    VALUE **vals;
  1144. X{
  1145. X    VALUE *vp, err, result;
  1146. X
  1147. X    if (count > 2)
  1148. X        vp = vals[2];
  1149. X    else {
  1150. X        err.v_num = _epsilon_;
  1151. X        err.v_type = V_NUM;
  1152. X        vp = &err;
  1153. X    }
  1154. X    powervalue(vals[0], vals[1], vp, &result);
  1155. X    return result;
  1156. X}
  1157. X
  1158. X
  1159. Xstatic VALUE
  1160. Xf_polar(count, vals)
  1161. X    VALUE **vals;
  1162. X{
  1163. X    VALUE *vp, err, result;
  1164. X    COMPLEX *c;
  1165. X
  1166. X    if (count > 2)
  1167. X        vp = vals[2];
  1168. X    else {
  1169. X        err.v_num = _epsilon_;
  1170. X        err.v_type = V_NUM;
  1171. X        vp = &err;
  1172. X    }
  1173. X    if ((vals[0]->v_type != V_NUM) || (vals[1]->v_type != V_NUM))
  1174. X        error("Non-real argument for polar");
  1175. X    if ((vp->v_type != V_NUM) || qisneg(vp->v_num) || qiszero(vp->v_num))
  1176. X        error("Bad epsilon value for polar");
  1177. X    c = cpolar(vals[0]->v_num, vals[1]->v_num, vp->v_num);
  1178. X    result.v_com = c;
  1179. X    result.v_type = V_COM;
  1180. X    if (cisreal(c)) {
  1181. X        result.v_num = qlink(c->real);
  1182. X        result.v_type = V_NUM;
  1183. X        comfree(c);
  1184. X    }
  1185. X    return result;
  1186. X}
  1187. X
  1188. X
  1189. Xstatic NUMBER *
  1190. Xf_ilog(val1, val2)
  1191. X    NUMBER *val1, *val2;
  1192. X{
  1193. X    return itoq(qilog(val1, val2));
  1194. X}
  1195. X
  1196. X
  1197. Xstatic NUMBER *
  1198. Xf_ilog2(val)
  1199. X    NUMBER *val;
  1200. X{
  1201. X    return itoq(qilog2(val));
  1202. X}
  1203. X
  1204. X
  1205. Xstatic NUMBER *
  1206. Xf_ilog10(val)
  1207. X    NUMBER *val;
  1208. X{
  1209. X    return itoq(qilog10(val));
  1210. X}
  1211. X
  1212. X
  1213. Xstatic NUMBER *
  1214. Xf_faccnt(val1, val2)
  1215. X    NUMBER *val1, *val2;
  1216. X{
  1217. X    return itoq(qdivcount(val1, val2));
  1218. X}
  1219. X
  1220. X
  1221. Xstatic VALUE
  1222. Xf_matfill(count, vals)
  1223. X    VALUE **vals;
  1224. X{
  1225. X    VALUE *v1, *v2, *v3;
  1226. X    VALUE result;
  1227. X
  1228. X    v1 = vals[0];
  1229. X    v2 = vals[1];
  1230. X    v3 = (count == 3) ? vals[2] : NULL;
  1231. X    if (v1->v_type != V_ADDR)
  1232. X        error("Non-variable argument for matfill");
  1233. X    v1 = v1->v_addr;
  1234. X    if (v1->v_type != V_MAT)
  1235. X        error("Non-matrix for matfill");
  1236. X    if (v2->v_type == V_ADDR)
  1237. X        v2 = v2->v_addr;
  1238. X    if (v3 && (v3->v_type == V_ADDR))
  1239. X        v3 = v3->v_addr;
  1240. X    matfill(v1->v_mat, v2, v3);
  1241. X    result.v_type = V_NULL;
  1242. X    return result;
  1243. X}
  1244. X
  1245. X
  1246. Xstatic VALUE
  1247. Xf_mattrans(vp)
  1248. X    VALUE *vp;
  1249. X{
  1250. X    VALUE result;
  1251. X
  1252. X    if (vp->v_type != V_MAT)
  1253. X        error("Non-matrix argument for mattrans");
  1254. X    result.v_type = V_MAT;
  1255. X    result.v_mat = mattrans(vp->v_mat);
  1256. X    return result;
  1257. X}
  1258. X
  1259. X
  1260. Xstatic VALUE
  1261. Xf_det(vp)
  1262. X    VALUE *vp;
  1263. X{
  1264. X    if (vp->v_type != V_MAT)
  1265. X        error("Non-matrix argument for det");
  1266. X    return matdet(vp->v_mat);
  1267. X}
  1268. X
  1269. X
  1270. Xstatic VALUE
  1271. Xf_matdim(vp)
  1272. X    VALUE *vp;
  1273. X{
  1274. X    VALUE result;
  1275. X
  1276. X    if (vp->v_type != V_MAT)
  1277. X        error("Non-matrix argument for matdim");
  1278. X    result.v_type = V_NUM;
  1279. X    result.v_num = itoq((long) vp->v_mat->m_dim);
  1280. X    return result;
  1281. X}
  1282. X
  1283. X
  1284. Xstatic VALUE
  1285. Xf_matmin(v1, v2)
  1286. X    VALUE *v1, *v2;
  1287. X{
  1288. X    VALUE result;
  1289. X    NUMBER *q;
  1290. X    long i;
  1291. X
  1292. X    if ((v1->v_type != V_MAT) || (v2->v_type != V_NUM))
  1293. X        error("Bad argument type for matmin");
  1294. X    q = v2->v_num;
  1295. X    i = qtoi(q);
  1296. X    if (qisfrac(q) || qisneg(q) || (i <= 0) || (i > v1->v_mat->m_dim))
  1297. X        error("Bad dimension value for matmin");
  1298. X    result.v_type = V_NUM;
  1299. X    result.v_num = itoq(v1->v_mat->m_min[i - 1]);
  1300. X    return result;
  1301. X}
  1302. X
  1303. X
  1304. Xstatic VALUE
  1305. Xf_matmax(v1, v2)
  1306. X    VALUE *v1, *v2;
  1307. X{
  1308. X    VALUE result;
  1309. X    NUMBER *q;
  1310. X    long i;
  1311. X
  1312. X    if ((v1->v_type != V_MAT) || (v2->v_type != V_NUM))
  1313. X        error("Bad argument type for matmax");
  1314. X    q = v2->v_num;
  1315. X    i = qtoi(q);
  1316. X    if (qisfrac(q) || qisneg(q) || (i <= 0) || (i > v1->v_mat->m_dim))
  1317. X        error("Bad dimension value for matmax");
  1318. X    result.v_type = V_NUM;
  1319. X    result.v_num = itoq(v1->v_mat->m_max[i - 1]);
  1320. X    return result;
  1321. X}
  1322. X
  1323. X
  1324. Xstatic VALUE
  1325. Xf_cp(v1, v2)
  1326. X    VALUE *v1, *v2;
  1327. X{
  1328. X    VALUE result;
  1329. X
  1330. X    if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT))
  1331. X        error("Non-matrix argument for cross product");
  1332. X    result.v_type = V_MAT;
  1333. X    result.v_mat = matcross(v1->v_mat, v2->v_mat);
  1334. X    return result;
  1335. X}
  1336. X
  1337. X
  1338. Xstatic VALUE
  1339. Xf_dp(v1, v2)
  1340. X    VALUE *v1, *v2;
  1341. X{
  1342. X    if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT))
  1343. X        error("Non-matrix argument for dot product");
  1344. X    return matdot(v1->v_mat, v2->v_mat);
  1345. X}
  1346. X
  1347. X
  1348. Xstatic VALUE
  1349. Xf_strlen(vp)
  1350. X    VALUE *vp;
  1351. X{
  1352. X    VALUE result;
  1353. X
  1354. X    if (vp->v_type != V_STR)
  1355. X        error("Non-string argument for strlen");
  1356. X    result.v_type = V_NUM;
  1357. X    result.v_num = itoq((long) strlen(vp->v_str));
  1358. X    return result;
  1359. X}
  1360. X
  1361. X
  1362. Xstatic VALUE
  1363. Xf_strcat(count, vals)
  1364. X    VALUE **vals;
  1365. X{
  1366. X    register VALUE **vp;
  1367. X    register char *cp;
  1368. X    int i;
  1369. X    long len;
  1370. X    long lengths[IN];
  1371. X    VALUE result;
  1372. X
  1373. X    len = 1;
  1374. X    vp = vals;
  1375. X    for (i = 0; i < count; i++) {
  1376. X        if ((*vp)->v_type != V_STR)
  1377. X            error("Non-string argument for strcat");
  1378. X        lengths[i] = strlen((*vp)->v_str);
  1379. X        len += lengths[i];
  1380. X        vp++;
  1381. X    }
  1382. X    cp = (char *)malloc(len);
  1383. X    if (cp == NULL)
  1384. X        error("No memory for strcat");
  1385. X    result.v_str = cp;
  1386. X    result.v_type = V_STR;
  1387. X    result.v_subtype = V_STRALLOC;
  1388. X    i = 0;
  1389. X    for (vp = vals; count-- > 0; vp++) {
  1390. X        strcpy(cp, (*vp)->v_str);
  1391. X        cp += lengths[i++];
  1392. X    }
  1393. X    return result;
  1394. X}
  1395. X
  1396. X
  1397. Xstatic VALUE
  1398. Xf_substr(v1, v2, v3)
  1399. X    VALUE *v1, *v2, *v3;
  1400. X{
  1401. X    NUMBER *q1, *q2;
  1402. X    long i1, i2, len;
  1403. X    char *cp;
  1404. X    VALUE result;
  1405. X
  1406. X    if (v1->v_type != V_STR)
  1407. X        error("Non-string argument for substr");
  1408. X    if ((v2->v_type != V_NUM) || (v3->v_type != V_NUM))
  1409. X        error("Non-numeric positions for substr");
  1410. X    q1 = v2->v_num;
  1411. X    q2 = v3->v_num;
  1412. X    if (qisfrac(q1) || qisneg(q1) || qisfrac(q2) || qisneg(q2))
  1413. X        error("Illegal positions for substr");
  1414. X    i1 = qtoi(q1);
  1415. X    i2 = qtoi(q2);
  1416. X    cp = v1->v_str;
  1417. X    len = strlen(cp);
  1418. X    result.v_type = V_STR;
  1419. X    if (i1 > 0)
  1420. X        i1--;
  1421. X    if (i1 >= len) {    /* indexing off of end */
  1422. X        result.v_subtype = V_STRLITERAL;
  1423. X        result.v_str = "";
  1424. X        return result;
  1425. X    }
  1426. X    cp += i1;
  1427. X    len -= i1;
  1428. X    if ((i2 >= len) && (v1->v_subtype == V_STRLITERAL)) {
  1429. X        result.v_subtype = V_STRLITERAL;
  1430. X        result.v_str = cp;
  1431. X        return result;
  1432. X    }
  1433. X    if (len > i2)
  1434. X        len = i2;
  1435. X    if (len == 1) {
  1436. X        result.v_subtype = V_STRLITERAL;
  1437. X        result.v_str = charstr(*cp);
  1438. X        return result;
  1439. X    }
  1440. X    result.v_subtype = V_STRALLOC;
  1441. X    result.v_str = (char *)malloc(len + 1);
  1442. X    if (result.v_str == NULL)
  1443. X        error("No memory for substr");
  1444. X    strncpy(result.v_str, cp, len);
  1445. X    result.v_str[len] = '\0';
  1446. X    return result;
  1447. X}
  1448. X
  1449. X
  1450. Xstatic VALUE
  1451. Xf_char(vp)
  1452. X    VALUE *vp;
  1453. X{
  1454. X    long num;
  1455. X    NUMBER *q;
  1456. X    VALUE result;
  1457. X
  1458. X    if (vp->v_type != V_NUM)
  1459. X        error("Non-numeric argument for char");
  1460. X    q = vp->v_num;
  1461. X    num = qtoi(q);
  1462. X    if (qisneg(q) || qisfrac(q) || isbig(q->num) || (num > 255))
  1463. X        error("Illegal number for char");
  1464. X    result.v_type = V_STR;
  1465. X    result.v_subtype = V_STRLITERAL;
  1466. X    result.v_str = charstr((int) num);
  1467. X    return result;
  1468. X}
  1469. X
  1470. X
  1471. Xstatic VALUE
  1472. Xf_ord(vp)
  1473. X    VALUE *vp;
  1474. X{
  1475. X    char *str;
  1476. X    VALUE result;
  1477. X
  1478. X    if (vp->v_type != V_STR)
  1479. X        error("Non-string argument for ord");
  1480. X    str = vp->v_str;
  1481. X    if (str[0] && str[1])
  1482. X        error("Multi-character string given for ord");
  1483. X    result.v_type = V_NUM;
  1484. X    result.v_num = itoq((long) (*str & 0xff));
  1485. X    return result;
  1486. X}
  1487. X
  1488. X
  1489. Xstatic VALUE
  1490. Xf_size(vp)
  1491. X    VALUE *vp;
  1492. X{
  1493. X    long count;
  1494. X    VALUE result;
  1495. X
  1496. X    switch (vp->v_type) {
  1497. X        case V_NULL:    count = 0; break;
  1498. X        case V_MAT:    count = vp->v_mat->m_size; break;
  1499. X        case V_LIST:    count = vp->v_list->l_count; break;
  1500. X        case V_OBJ:    count = vp->v_obj->o_actions->count; break;
  1501. X        default:    count = 1; break;
  1502. X    }
  1503. X    result.v_type = V_NUM;
  1504. X    result.v_num = itoq(count);
  1505. X    return result;
  1506. X}
  1507. X
  1508. X
  1509. Xstatic VALUE
  1510. Xf_search(count, vals)
  1511. X    VALUE **vals;
  1512. X{
  1513. X    VALUE *v1, *v2;
  1514. X    NUMBER *q;
  1515. X    long start;
  1516. X    long index;
  1517. X    VALUE result;
  1518. X
  1519. X    v1 = *vals++;
  1520. X    v2 = *vals++;
  1521. X    start = 0;
  1522. X    if (count == 3) {
  1523. X        if ((*vals)->v_type != V_NUM)
  1524. X            error("Non-numeric start index for search");
  1525. X        q = (*vals)->v_num;
  1526. X        if (qisfrac(q) || qisneg(q))
  1527. X            error("Bad start index for search");
  1528. X        start = qtoi(q);
  1529. X    }
  1530. X    switch (v1->v_type) {
  1531. X        case V_MAT:
  1532. X            index = matsearch(v1->v_mat, v2, start);
  1533. X            break;
  1534. X        case V_LIST:
  1535. X            index = listsearch(v1->v_list, v2, start);
  1536. X            break;
  1537. X        default:
  1538. X            error("Bad argument type for search");
  1539. X    }
  1540. X    result.v_type = V_NULL;
  1541. X    if (index >= 0) {
  1542. X        result.v_type = V_NUM;
  1543. X        result.v_num = itoq(index);
  1544. X    }
  1545. X    return result;
  1546. X}
  1547. X
  1548. X
  1549. Xstatic VALUE
  1550. Xf_rsearch(count, vals)
  1551. X    VALUE **vals;
  1552. X{
  1553. X    VALUE *v1, *v2;
  1554. X    NUMBER *q;
  1555. X    long start;
  1556. X    long index;
  1557. X    VALUE result;
  1558. X
  1559. X    v1 = *vals++;
  1560. X    v2 = *vals++;
  1561. X    start = MAXFULL;
  1562. X    if (count == 3) {
  1563. X        if ((*vals)->v_type != V_NUM)
  1564. X            error("Non-numeric start index for rsearch");
  1565. X        q = (*vals)->v_num;
  1566. X        if (qisfrac(q) || qisneg(q))
  1567. X            error("Bad start index for rsearch");
  1568. X        start = qtoi(q);
  1569. X    }
  1570. X    switch (v1->v_type) {
  1571. X        case V_MAT:
  1572. X            index = matrsearch(v1->v_mat, v2, start);
  1573. X            break;
  1574. X        case V_LIST:
  1575. X            index = listrsearch(v1->v_list, v2, start);
  1576. X            break;
  1577. X        default:
  1578. X            error("Bad argument type for rsearch");
  1579. X    }
  1580. X    result.v_type = V_NULL;
  1581. X    if (index >= 0) {
  1582. X        result.v_type = V_NUM;
  1583. X        result.v_num = itoq(index);
  1584. X    }
  1585. X    return result;
  1586. X}
  1587. X
  1588. X
  1589. Xstatic VALUE
  1590. Xf_list(count, vals)
  1591. X    VALUE **vals;
  1592. X{
  1593. X    VALUE result;
  1594. X
  1595. X    result.v_type = V_LIST;
  1596. X    result.v_list = listalloc();
  1597. X    while (count-- > 0)
  1598. X        insertlistlast(result.v_list, *vals++);
  1599. X    return result;
  1600. X}
  1601. X
  1602. X
  1603. Xstatic VALUE
  1604. Xf_listinsert(v1, v2, v3)
  1605. X    VALUE *v1, *v2, *v3;
  1606. X{
  1607. X    VALUE result;
  1608. X
  1609. X    if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
  1610. X        error("Inserting into non-list variable");
  1611. X    if (v2->v_type == V_ADDR)
  1612. X        v2 = v2->v_addr;
  1613. X    if ((v2->v_type != V_NUM) || qisfrac(v2->v_num))
  1614. X        error("Non-integral index for list insert");
  1615. X    if (v3->v_type == V_ADDR)
  1616. X        v3 = v3->v_addr;
  1617. X    insertlistmiddle(v1->v_addr->v_list, qtoi(v2->v_num), v3);
  1618. X    result.v_type = V_NULL;
  1619. X    return result;
  1620. X}
  1621. X
  1622. X
  1623. Xstatic VALUE
  1624. Xf_listpush(v1, v2)
  1625. X    VALUE *v1, *v2;
  1626. X{
  1627. X    VALUE result;
  1628. X
  1629. X    if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
  1630. X        error("Pushing onto non-list variable");
  1631. X    if (v2->v_type == V_ADDR)
  1632. X        v2 = v2->v_addr;
  1633. X    insertlistfirst(v1->v_addr->v_list, v2);
  1634. X    result.v_type = V_NULL;
  1635. X    return result;
  1636. X}
  1637. X
  1638. X
  1639. Xstatic VALUE
  1640. Xf_listappend(v1, v2)
  1641. X    VALUE *v1, *v2;
  1642. X{
  1643. X    VALUE result;
  1644. X
  1645. X    if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
  1646. X        error("Appending to non-list variable");
  1647. X    if (v2->v_type == V_ADDR)
  1648. X        v2 = v2->v_addr;
  1649. X    insertlistlast(v1->v_addr->v_list, v2);
  1650. X    result.v_type = V_NULL;
  1651. X    return result;
  1652. X}
  1653. X
  1654. X
  1655. Xstatic VALUE
  1656. Xf_listdelete(v1, v2)
  1657. X    VALUE *v1, *v2;
  1658. X{
  1659. X    VALUE result;
  1660. X
  1661. X    if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
  1662. X        error("Deleting from non-list variable");
  1663. X    if (v2->v_type == V_ADDR)
  1664. X        v2 = v2->v_addr;
  1665. X    if ((v2->v_type != V_NUM) || qisfrac(v2->v_num))
  1666. X        error("Non-integral index for list delete");
  1667. X    removelistmiddle(v1->v_addr->v_list, qtoi(v2->v_num), &result);
  1668. X    return result;
  1669. X}
  1670. X
  1671. X
  1672. Xstatic VALUE
  1673. Xf_listpop(vp)
  1674. X    VALUE *vp;
  1675. X{
  1676. X    VALUE result;
  1677. X
  1678. X    if ((vp->v_type != V_ADDR) || (vp->v_addr->v_type != V_LIST))
  1679. X        error("Popping from non-list variable");
  1680. X    removelistfirst(vp->v_addr->v_list, &result);
  1681. X    return result;
  1682. X}
  1683. X
  1684. X
  1685. Xstatic VALUE
  1686. Xf_listremove(vp)
  1687. X    VALUE *vp;
  1688. X{
  1689. X    VALUE result;
  1690. X
  1691. X    if ((vp->v_type != V_ADDR) || (vp->v_addr->v_type != V_LIST))
  1692. X        error("Removing from non-list variable");
  1693. X    removelistlast(vp->v_addr->v_list, &result);
  1694. X    return result;
  1695. X}
  1696. X
  1697. X
  1698. X/*
  1699. X * Return the current runtime of calc in seconds.
  1700. X * This is the user mode time only.
  1701. X */
  1702. Xstatic NUMBER *
  1703. Xf_runtime()
  1704. X{
  1705. X    struct tms buf;
  1706. X
  1707. X    times(&buf);
  1708. X    return iitoq((long) buf.tms_utime, (long) CLK_TCK);
  1709. X}
  1710. X
  1711. X
  1712. Xstatic VALUE
  1713. Xf_fopen(v1, v2)
  1714. X    VALUE *v1, *v2;
  1715. X{
  1716. X    VALUE result;
  1717. X    FILEID id;
  1718. X
  1719. X    if (v1->v_type != V_STR)
  1720. X        error("Non-string filename for fopen");
  1721. X    if (v2->v_type != V_STR)
  1722. X        error("Non-string mode for fopen");
  1723. X    id = openid(v1->v_str, v2->v_str);
  1724. X    if (id == FILEID_NONE) {
  1725. X        result.v_type = V_NUM;
  1726. X        result.v_num = itoq((long) errno);
  1727. X    } else {
  1728. X        result.v_type = V_FILE;
  1729. X        result.v_file = id;
  1730. X    }
  1731. X    return result;
  1732. X}
  1733. X
  1734. X
  1735. Xstatic VALUE
  1736. Xf_fclose(vp)
  1737. X    VALUE *vp;
  1738. X{
  1739. X    VALUE result;
  1740. X
  1741. X    if (vp->v_type != V_FILE)
  1742. X        error("Non-file for fclose");
  1743. X    if (closeid(vp->v_file)) {
  1744. X        result.v_type = V_NUM;
  1745. X        result.v_num = itoq((long) errno);
  1746. X    } else
  1747. X        result.v_type = V_NULL;
  1748. X    return result;
  1749. X}
  1750. X
  1751. X
  1752. Xstatic VALUE
  1753. Xf_ferror(vp)
  1754. X    VALUE *vp;
  1755. X{
  1756. X    VALUE result;
  1757. X
  1758. X    if (vp->v_type != V_FILE)
  1759. X        error("Non-file for ferror");
  1760. X    result.v_type = V_NUM;
  1761. X    result.v_num = itoq((long) errorid(vp->v_file));
  1762. X    return result;
  1763. X}
  1764. X
  1765. X
  1766. Xstatic VALUE
  1767. Xf_feof(vp)
  1768. X    VALUE *vp;
  1769. X{
  1770. X    VALUE result;
  1771. X
  1772. X    if (vp->v_type != V_FILE)
  1773. X        error("Non-file for feof");
  1774. X    result.v_type = V_NUM;
  1775. X    result.v_num = itoq((long) eofid(vp->v_file));
  1776. X    return result;
  1777. X}
  1778. X
  1779. X
  1780. Xstatic VALUE
  1781. Xf_fflush(vp)
  1782. X    VALUE *vp;
  1783. X{
  1784. X    VALUE result;
  1785. X
  1786. X    if (vp->v_type != V_FILE)
  1787. X        error("Non-file for fflush");
  1788. X    flushid(vp->v_file);
  1789. X    result.v_type = V_NULL;
  1790. X    return result;
  1791. X}
  1792. X
  1793. X
  1794. Xstatic VALUE
  1795. Xf_fprintf(count, vals)
  1796. X    VALUE **vals;
  1797. X{
  1798. X    VALUE result;
  1799. X
  1800. X    if (vals[0]->v_type != V_FILE)
  1801. X        error("Non-file for fprintf");
  1802. X    if (vals[1]->v_type != V_STR)
  1803. X        error("Non-string format for fprintf");
  1804. X    idprintf(vals[0]->v_file, vals[1]->v_str, count - 2, vals + 2);
  1805. X    result.v_type = V_NULL;
  1806. X    return result;
  1807. X}
  1808. X
  1809. X
  1810. Xstatic VALUE
  1811. Xf_printf(count, vals)
  1812. X    VALUE **vals;
  1813. X{
  1814. X    VALUE result;
  1815. X
  1816. X    if (vals[0]->v_type != V_STR)
  1817. X        error("Non-string format for printf");
  1818. X    idprintf(FILEID_STDOUT, vals[0]->v_str, count - 1, vals + 1);
  1819. X    result.v_type = V_NULL;
  1820. X    return result;
  1821. X}
  1822. X
  1823. X
  1824. Xstatic VALUE
  1825. Xf_strprintf(count, vals)
  1826. X    VALUE **vals;
  1827. X{
  1828. X    VALUE result;
  1829. X
  1830. X    if (vals[0]->v_type != V_STR)
  1831. X        error("Non-string format for strprintf");
  1832. X    divertio();
  1833. X    idprintf(FILEID_STDOUT, vals[0]->v_str, count - 1, vals + 1);
  1834. X    result.v_str = getdivertedio();
  1835. X    result.v_type = V_STR;
  1836. X    result.v_subtype = V_STRALLOC;
  1837. X    return result;
  1838. X}
  1839. X
  1840. X
  1841. Xstatic VALUE
  1842. Xf_fgetc(vp)
  1843. X    VALUE *vp;
  1844. X{
  1845. X    VALUE result;
  1846. X    int ch;
  1847. X
  1848. X    if (vp->v_type != V_FILE)
  1849. X        error("Non-file for fgetc");
  1850. X    ch = getcharid(vp->v_file);
  1851. X    result.v_type = V_NULL;
  1852. X    if (ch != EOF) {
  1853. X        result.v_type = V_STR;
  1854. X        result.v_subtype = V_STRLITERAL;
  1855. X        result.v_str = charstr(ch);
  1856. X    }
  1857. X    return result;
  1858. X}
  1859. X
  1860. X
  1861. Xstatic VALUE
  1862. Xf_fgetline(vp)
  1863. X    VALUE *vp;
  1864. X{
  1865. X    VALUE result;
  1866. X    char *str;
  1867. X
  1868. X    if (vp->v_type != V_FILE)
  1869. X        error("Non-file for fgetline");
  1870. X    readid(vp->v_file, &str);
  1871. X    result.v_type = V_NULL;
  1872. X    if (str) {
  1873. X        result.v_type = V_STR;
  1874. X        result.v_subtype = V_STRALLOC;
  1875. X        result.v_str = str;
  1876. X    }
  1877. X    return result;
  1878. X}
  1879. X
  1880. X
  1881. Xstatic VALUE
  1882. Xf_files(count, vals)
  1883. X    VALUE **vals;
  1884. X{
  1885. X    VALUE result;
  1886. X
  1887. X    if (count == 0) {
  1888. X        result.v_type = V_NUM;
  1889. X        result.v_num = itoq((long) MAXFILES);
  1890. X        return result;
  1891. X    }
  1892. X    if ((vals[0]->v_type != V_NUM) || qisfrac(vals[0]->v_num))
  1893. X        error("Non-integer for files");
  1894. X    result.v_type = V_NULL;
  1895. X    result.v_file = indexid(qtoi(vals[0]->v_num));
  1896. X    if (result.v_file != FILEID_NONE)
  1897. X        result.v_type = V_FILE;
  1898. X    return result;
  1899. X}
  1900. X
  1901. X
  1902. X/*
  1903. X * Show the list of primitive built-in functions
  1904. X */
  1905. Xvoid
  1906. Xshowbuiltins()
  1907. X{
  1908. X    register struct builtin *bp;    /* current function */
  1909. X
  1910. X    printf("\nName\tArgs\tDescription\n\n");
  1911. X    for (bp = builtins; bp->b_name; bp++) {
  1912. X        printf("%-9s ", bp->b_name);
  1913. X        if (bp->b_maxargs == IN)
  1914. X            printf("%d+    ", bp->b_minargs);
  1915. X        else if (bp->b_minargs == bp->b_maxargs)
  1916. X            printf("%-6d", bp->b_minargs);
  1917. X        else
  1918. X            printf("%d-%-4d", bp->b_minargs, bp->b_maxargs);
  1919. X        printf(" %s\n", bp->b_desc);
  1920. X    }
  1921. X    printf("\n");
  1922. X}
  1923. X
  1924. X
  1925. X/*
  1926. X * Return the index of a built-in function given its name.
  1927. X * Returns minus one if the name is not known.
  1928. X */
  1929. Xgetbuiltinfunc(name)
  1930. X    char *name;
  1931. X{
  1932. X    register struct builtin *bp;
  1933. X
  1934. X    for (bp = builtins; bp->b_name; bp++) {
  1935. X        if ((*name == *bp->b_name) && (strcmp(name, bp->b_name) == 0))
  1936. X        return (bp - builtins);
  1937. X    }
  1938. X    return -1;
  1939. X}
  1940. X
  1941. X
  1942. X/*
  1943. X * Given the index of a built-in function, return its name.
  1944. X */
  1945. Xchar *
  1946. Xbuiltinname(index)
  1947. X    long index;
  1948. X{
  1949. X    if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1)
  1950. X        return "";
  1951. X    return builtins[index].b_name;
  1952. X}
  1953. X
  1954. X
  1955. X/*
  1956. X * Given the index of a built-in function, and the number of arguments seen,
  1957. X * determine if the number of arguments are legal.  This routine is called
  1958. X * during parsing time.
  1959. X */
  1960. Xvoid
  1961. Xbuiltincheck(index, count)
  1962. X    long index;
  1963. X{
  1964. X    register struct builtin *bp;
  1965. X
  1966. X    if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1)
  1967. X        error("Unknown built in index");
  1968. X    bp = &builtins[index];
  1969. X    if (count < bp->b_minargs)
  1970. X        scanerror(T_NULL, "Too few arguments for builtin function \"%s\"",
  1971. X    bp->b_name);
  1972. X    if (count > bp->b_maxargs)
  1973. X        scanerror(T_NULL, "Too many arguments for builtin function \"%s\"",
  1974. X            bp->b_name);
  1975. X}
  1976. X
  1977. X
  1978. X/*
  1979. X * Return the opcode for a built-in function that can be used to avoid
  1980. X * the function call at all.
  1981. X */
  1982. Xbuiltinopcode(index)
  1983. X    long index;
  1984. X{
  1985. X    if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1)
  1986. X        return OP_NOP;
  1987. X    return builtins[index].b_opcode;
  1988. X}
  1989. X
  1990. X/* END CODE */
  1991. END_OF_FILE
  1992. if test 47105 -ne `wc -c <'func.c'`; then
  1993.     echo shar: \"'func.c'\" unpacked with wrong size!
  1994. fi
  1995. # end of 'func.c'
  1996. fi
  1997. echo shar: End of archive 20 \(of 21\).
  1998. cp /dev/null ark20isdone
  1999. MISSING=""
  2000. for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 ; do
  2001.     if test ! -f ark${I}isdone ; then
  2002.     MISSING="${MISSING} ${I}"
  2003.     fi
  2004. done
  2005. if test "${MISSING}" = "" ; then
  2006.     echo You have unpacked all 21 archives.
  2007.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  2008. else
  2009.     echo You still need to unpack the following archives:
  2010.     echo "        " ${MISSING}
  2011. fi
  2012. ##  End of shell archive.
  2013. exit 0
  2014.