Files
calc/func.c
Landon Curt Noll ff90bc0e3a add E_STRING to error, errno, strerror, change multiple E_STRING's
While help/errstr has been added, the errstr builtin function is
not yet written.  In anticipation of the new errstr builtin the
rest of the calc error system has been updated to associated errsym
E_STRING's with errnum error codes and errmsg error messages.

Minor improvements to help/rand.

The verify_error_table() function that does a verification
the error_table[] array and setup private_error_alias[] array
is now called by libcalc_call_me_first().

Fix comment about wrong include file in have_sys_mount.h.

Removed unused booltostr() and strtobool() macros from bool.h.

Moved define of math_error(char *, ...) from zmath.h to errtbl.h.
The errtbl.h include file, unless ERRCODE_SRC is defined
also includes attribute.h and errsym.h.

Group calc error related builtin support functions together in func.c.

Make switch indenting in func.c consistent.

Passing an invalid argument to error(), errno() or strerror() will
set errno AND throw a math error.  Before errno would be set and
an error value was returned.  Before there was no way to tell if
the error value was a result of the arg or if an error detected.

Added E_STRING to error([errnum | "E_STRING"]) builtin function.
Added E_STRING to errno([errnum | "E_STRING"]) builtin function.
Added E_STRING to strerror([errnum | "E_STRING"]) builtin function.
Calling these functions with an E_STRING errsym is the same as calling
them with the matching errnum code.

Standardized on calc computation error related E_STRING strings
where there are a set of related codes.  Changed "E_...digits" into
"E_..._digits".  For example, E_FPUTC1 became E_FPUTC_1, E_FPUTC2
became E_FPUTC_2, and E_FPUTC3 became E_FPUTC_3.  In a few cases
such as E_APPR became E_APPR_1, because there was a E_APPR2 (which
became E_APPR_2) and E_APPR3 (which became E_APPR_3).  To other
special cases, E_ILOG10 became E_IBASE10_LOG and E_ILOG2 became
E_IBASE2_LOG because E_ILOG10 and E_ILOG2 are both independent calc
computation error related E_STRING strings.  Now related sets of
E_STRING strings end in _ (underscore) followed by digits.

The following is the list of E_STRING strings changes:

    E_APPR ==> E_APPR_1
    E_ROUND ==> E_ROUND_1
    E_SQRT ==> E_SQRT_1
    E_ROOT ==> E_ROOT_1
    E_SHIFT ==> E_SHIFT_1
    E_SCALE ==> E_SCALE_1
    E_POWI ==> E_POWI_1
    E_POWER ==> E_POWER_1
    E_QUO ==> E_QUO_1
    E_MOD ==> E_MOD_1
    E_ABS ==> E_ABS_1
    E_APPR2 ==> E_APPR_2
    E_APPR3 ==> E_APPR_3
    E_ROUND2 ==> E_ROUND_2
    E_ROUND3 ==> E_ROUND_3
    E_BROUND2 ==> E_BROUND_2
    E_BROUND3 ==> E_BROUND_3
    E_SQRT2 ==> E_SQRT_2
    E_SQRT3 ==> E_SQRT_3
    E_ROOT2 ==> E_ROOT_2
    E_ROOT3 ==> E_ROOT_3
    E_SHIFT2 ==> E_SHIFT_2
    E_SCALE2 ==> E_SCALE_2
    E_POWI2 ==> E_POWI_2
    E_POWER2 ==> E_POWER_2
    E_POWER3 ==> E_POWER_3
    E_QUO2 ==> E_QUO_2
    E_QUO3 ==> E_QUO_3
    E_MOD2 ==> E_MOD_2
    E_MOD3 ==> E_MOD_3
    E_ABS2 ==> E_ABS_2
    E_EXP1 ==> E_EXP_1
    E_EXP2 ==> E_EXP_2
    E_FPUTC1 ==> E_FPUTC_1
    E_FPUTC2 ==> E_FPUTC_2
    E_FPUTC3 ==> E_FPUTC_3
    E_FGETC1 ==> E_FGETC_1
    E_FGETC2 ==> E_FGETC_2
    E_FOPEN1 ==> E_FOPEN_1
    E_FOPEN2 ==> E_FOPEN_2
    E_FREOPEN1 ==> E_FREOPEN_1
    E_FREOPEN2 ==> E_FREOPEN_2
    E_FREOPEN3 ==> E_FREOPEN_3
    E_FCLOSE1 ==> E_FCLOSE_1
    E_FPUTS1 ==> E_FPUTS_1
    E_FPUTS2 ==> E_FPUTS_2
    E_FPUTS3 ==> E_FPUTS_3
    E_FGETS1 ==> E_FGETS_1
    E_FGETS2 ==> E_FGETS_2
    E_FPUTSTR1 ==> E_FPUTSTR_1
    E_FPUTSTR2 ==> E_FPUTSTR_2
    E_FPUTSTR3 ==> E_FPUTSTR_3
    E_FGETSTR1 ==> E_FGETSTR_1
    E_FGETSTR2 ==> E_FGETSTR_2
    E_FGETLINE1 ==> E_FGETLINE_1
    E_FGETLINE2 ==> E_FGETLINE_2
    E_FGETFIELD1 ==> E_FGETFIELD_1
    E_FGETFIELD2 ==> E_FGETFIELD_2
    E_REWIND1 ==> E_REWIND_1
    E_PRINTF1 ==> E_PRINTF_1
    E_PRINTF2 ==> E_PRINTF_2
    E_FPRINTF1 ==> E_FPRINTF_1
    E_FPRINTF2 ==> E_FPRINTF_2
    E_FPRINTF3 ==> E_FPRINTF_3
    E_STRPRINTF1 ==> E_STRPRINTF_1
    E_STRPRINTF2 ==> E_STRPRINTF_2
    E_FSCAN1 ==> E_FSCAN_1
    E_FSCAN2 ==> E_FSCAN_2
    E_FSCANF1 ==> E_FSCANF_1
    E_FSCANF2 ==> E_FSCANF_2
    E_FSCANF3 ==> E_FSCANF_3
    E_FSCANF4 ==> E_FSCANF_4
    E_STRSCANF1 ==> E_STRSCANF_1
    E_STRSCANF2 ==> E_STRSCANF_2
    E_STRSCANF3 ==> E_STRSCANF_3
    E_STRSCANF4 ==> E_STRSCANF_4
    E_SCANF1 ==> E_SCANF_1
    E_SCANF2 ==> E_SCANF_2
    E_SCANF3 ==> E_SCANF_3
    E_FTELL1 ==> E_FTELL_1
    E_FTELL2 ==> E_FTELL_2
    E_FSEEK1 ==> E_FSEEK_1
    E_FSEEK2 ==> E_FSEEK_2
    E_FSEEK3 ==> E_FSEEK_3
    E_FSIZE1 ==> E_FSIZE_1
    E_FSIZE2 ==> E_FSIZE_2
    E_FEOF1 ==> E_FEOF_1
    E_FEOF2 ==> E_FEOF_2
    E_FERROR1 ==> E_FERROR_1
    E_FERROR2 ==> E_FERROR_2
    E_UNGETC1 ==> E_UNGETC_1
    E_UNGETC2 ==> E_UNGETC_2
    E_UNGETC3 ==> E_UNGETC_3
    E_ISATTY1 ==> E_ISATTY_1
    E_ISATTY2 ==> E_ISATTY_2
    E_ACCESS1 ==> E_ACCESS_1
    E_ACCESS2 ==> E_ACCESS_2
    E_SEARCH1 ==> E_SEARCH_1
    E_SEARCH2 ==> E_SEARCH_2
    E_SEARCH3 ==> E_SEARCH_3
    E_SEARCH4 ==> E_SEARCH_4
    E_SEARCH5 ==> E_SEARCH_5
    E_SEARCH6 ==> E_SEARCH_6
    E_RSEARCH1 ==> E_RSEARCH_1
    E_RSEARCH2 ==> E_RSEARCH_2
    E_RSEARCH3 ==> E_RSEARCH_3
    E_RSEARCH4 ==> E_RSEARCH_4
    E_RSEARCH5 ==> E_RSEARCH_5
    E_RSEARCH6 ==> E_RSEARCH_6
    E_REWIND2 ==> E_REWIND_2
    E_STRERROR1 ==> E_STRERROR_1
    E_STRERROR2 ==> E_STRERROR_2
    E_COS1 ==> E_COS_1
    E_COS2 ==> E_COS_2
    E_SIN1 ==> E_SIN_1
    E_SIN2 ==> E_SIN_2
    E_EVAL2 ==> E_EVAL_2
    E_ARG1 ==> E_ARG_1
    E_ARG2 ==> E_ARG_2
    E_POLAR1 ==> E_POLAR_1
    E_POLAR2 ==> E_POLAR_2
    E_MATFILL1 ==> E_MATFILL_1
    E_MATFILL2 ==> E_MATFILL_2
    E_MATTRANS1 ==> E_MATTRANS_1
    E_MATTRANS2 ==> E_MATTRANS_2
    E_DET1 ==> E_DET_1
    E_DET2 ==> E_DET_2
    E_DET3 ==> E_DET_3
    E_MATMIN1 ==> E_MATMIN_1
    E_MATMIN2 ==> E_MATMIN_2
    E_MATMIN3 ==> E_MATMIN_3
    E_MATMAX1 ==> E_MATMAX_1
    E_MATMAX2 ==> E_MATMAX_2
    E_MATMAX3 ==> E_MATMAX_3
    E_CP1 ==> E_CP_1
    E_CP2 ==> E_CP_2
    E_CP3 ==> E_CP_3
    E_DP1 ==> E_DP_1
    E_DP2 ==> E_DP_2
    E_DP3 ==> E_DP_3
    E_SUBSTR1 ==> E_SUBSTR_1
    E_SUBSTR2 ==> E_SUBSTR_2
    E_INSERT1 ==> E_INSERT_1
    E_INSERT2 ==> E_INSERT_2
    E_DELETE1 ==> E_DELETE_1
    E_DELETE2 ==> E_DELETE_2
    E_LN1 ==> E_LN_1
    E_LN2 ==> E_LN_2
    E_ERROR1 ==> E_ERROR_1
    E_ERROR2 ==> E_ERROR_2
    E_EVAL3 ==> E_EVAL_3
    E_EVAL4 ==> E_EVAL_4
    E_RM1 ==> E_RM_1
    E_RM2 ==> E_RM_2
    E_BLK1 ==> E_BLK_1
    E_BLK2 ==> E_BLK_2
    E_BLK3 ==> E_BLK_3
    E_BLK4 ==> E_BLK_4
    E_BLKFREE1 ==> E_BLKFREE_1
    E_BLKFREE2 ==> E_BLKFREE_2
    E_BLKFREE3 ==> E_BLKFREE_3
    E_BLKFREE4 ==> E_BLKFREE_4
    E_BLKFREE5 ==> E_BLKFREE_5
    E_BLOCKS1 ==> E_BLOCKS_1
    E_BLOCKS2 ==> E_BLOCKS_2
    E_COPY1 ==> E_COPY_01
    E_COPY2 ==> E_COPY_02
    E_COPY3 ==> E_COPY_03
    E_COPY4 ==> E_COPY_04
    E_COPY5 ==> E_COPY_05
    E_COPY6 ==> E_COPY_06
    E_COPY7 ==> E_COPY_07
    E_COPY8 ==> E_COPY_08
    E_COPY9 ==> E_COPY_09
    E_COPY10 ==> E_COPY_10
    E_COPY11 ==> E_COPY_11
    E_COPY12 ==> E_COPY_12
    E_COPY13 ==> E_COPY_13
    E_COPY14 ==> E_COPY_14
    E_COPY15 ==> E_COPY_15
    E_COPY16 ==> E_COPY_16
    E_COPY17 ==> E_COPY_17
    E_COPYF1 ==> E_COPYF_1
    E_COPYF2 ==> E_COPYF_2
    E_COPYF3 ==> E_COPYF_3
    E_COPYF4 ==> E_COPYF_4
    E_PROTECT1 ==> E_PROTECT_1
    E_PROTECT2 ==> E_PROTECT_2
    E_PROTECT3 ==> E_PROTECT_3
    E_MATFILL3 ==> E_MATFILL_3
    E_MATFILL4 ==> E_MATFILL_4
    E_MATTRACE1 ==> E_MATTRACE_1
    E_MATTRACE2 ==> E_MATTRACE_2
    E_MATTRACE3 ==> E_MATTRACE_3
    E_TAN1 ==> E_TAN_1
    E_TAN2 ==> E_TAN_2
    E_COT1 ==> E_COT_1
    E_COT2 ==> E_COT_2
    E_SEC1 ==> E_SEC_1
    E_SEC2 ==> E_SEC_2
    E_CSC1 ==> E_CSC_1
    E_CSC2 ==> E_CSC_2
    E_SINH1 ==> E_SINH_1
    E_SINH2 ==> E_SINH_2
    E_COSH1 ==> E_COSH_1
    E_COSH2 ==> E_COSH_2
    E_TANH1 ==> E_TANH_1
    E_TANH2 ==> E_TANH_2
    E_COTH1 ==> E_COTH_1
    E_COTH2 ==> E_COTH_2
    E_SECH1 ==> E_SECH_1
    E_SECH2 ==> E_SECH_2
    E_CSCH1 ==> E_CSCH_1
    E_CSCH2 ==> E_CSCH_2
    E_ASIN1 ==> E_ASIN_1
    E_ASIN2 ==> E_ASIN_2
    E_ACOS1 ==> E_ACOS_1
    E_ACOS2 ==> E_ACOS_2
    E_ATAN1 ==> E_ATAN_1
    E_ATAN2 ==> E_ATAN_2
    E_ACOT1 ==> E_ACOT_1
    E_ACOT2 ==> E_ACOT_2
    E_ASEC1 ==> E_ASEC_1
    E_ASEC2 ==> E_ASEC_2
    E_ACSC1 ==> E_ACSC_1
    E_ACSC2 ==> E_ACSC_2
    E_ASINH1 ==> E_ASINH_1
    E_ASINH2 ==> E_ASINH_2
    E_ACOSH1 ==> E_ACOSH_1
    E_ACOSH2 ==> E_ACOSH_2
    E_ATANH1 ==> E_ATANH_1
    E_ATANH2 ==> E_ATANH_2
    E_ACOTH1 ==> E_ACOTH_1
    E_ACOTH2 ==> E_ACOTH_2
    E_ASECH1 ==> E_ASECH_1
    E_ASECH2 ==> E_ASECH_2
    E_ACSCH1 ==> E_ACSCH_1
    E_ACSCH2 ==> E_ACSCH_2
    E_GD1 ==> E_GD_1
    E_GD2 ==> E_GD_2
    E_AGD1 ==> E_AGD_1
    E_AGD2 ==> E_AGD_2
    E_BIT1 ==> E_BIT_1
    E_BIT2 ==> E_BIT_2
    E_SETBIT1 ==> E_SETBIT_1
    E_SETBIT2 ==> E_SETBIT_2
    E_SETBIT3 ==> E_SETBIT_3
    E_SEG1 ==> E_SEG_1
    E_SEG2 ==> E_SEG_2
    E_SEG3 ==> E_SEG_3
    E_HIGHBIT1 ==> E_HIGHBIT_1
    E_HIGHBIT2 ==> E_HIGHBIT_2
    E_LOWBIT1 ==> E_LOWBIT_1
    E_LOWBIT2 ==> E_LOWBIT_2
    E_HEAD1 ==> E_HEAD_1
    E_HEAD2 ==> E_HEAD_2
    E_TAIL1 ==> E_TAIL_1
    E_TAIL2 ==> E_TAIL_2
    E_XOR1 ==> E_XOR_1
    E_XOR2 ==> E_XOR_2
    E_INDICES1 ==> E_INDICES_1
    E_INDICES2 ==> E_INDICES_2
    E_EXP3 ==> E_EXP_3
    E_SINH3 ==> E_SINH_3
    E_COSH3 ==> E_COSH_3
    E_SIN3 ==> E_SIN_3
    E_COS3 ==> E_COS_3
    E_GD3 ==> E_GD_3
    E_AGD3 ==> E_AGD_3
    E_POWER4 ==> E_POWER_4
    E_ROOT4 ==> E_ROOT_4
    E_DGT1 ==> E_DGT_1
    E_DGT2 ==> E_DGT_2
    E_DGT3 ==> E_DGT_3
    E_PLCS1 ==> E_PLCS_1
    E_PLCS2 ==> E_PLCS_2
    E_DGTS1 ==> E_DGTS_1
    E_DGTS2 ==> E_DGTS_2
    E_ILOG10 ==> E_IBASE10_LOG
    E_ILOG2 ==> E_IBASE2_LOG
    E_COMB1 ==> E_COMB_1
    E_COMB2 ==> E_COMB_2
    E_ASSIGN1 ==> E_ASSIGN_1
    E_ASSIGN2 ==> E_ASSIGN_2
    E_ASSIGN3 ==> E_ASSIGN_3
    E_ASSIGN4 ==> E_ASSIGN_4
    E_ASSIGN5 ==> E_ASSIGN_5
    E_ASSIGN6 ==> E_ASSIGN_6
    E_ASSIGN7 ==> E_ASSIGN_7
    E_ASSIGN8 ==> E_ASSIGN_8
    E_ASSIGN9 ==> E_ASSIGN_9
    E_SWAP1 ==> E_SWAP_1
    E_SWAP2 ==> E_SWAP_2
    E_SWAP3 ==> E_SWAP_3
    E_QUOMOD1 ==> E_QUOMOD_1
    E_QUOMOD2 ==> E_QUOMOD_2
    E_QUOMOD3 ==> E_QUOMOD_3
    E_PREINC1 ==> E_PREINC_1
    E_PREINC2 ==> E_PREINC_2
    E_PREINC3 ==> E_PREINC_3
    E_PREDEC1 ==> E_PREDEC_1
    E_PREDEC2 ==> E_PREDEC_2
    E_PREDEC3 ==> E_PREDEC_3
    E_POSTINC1 ==> E_POSTINC_1
    E_POSTINC2 ==> E_POSTINC_2
    E_POSTINC3 ==> E_POSTINC_3
    E_POSTDEC1 ==> E_POSTDEC_1
    E_POSTDEC2 ==> E_POSTDEC_2
    E_POSTDEC3 ==> E_POSTDEC_3
    E_INIT1 ==> E_INIT_01
    E_INIT2 ==> E_INIT_02
    E_INIT3 ==> E_INIT_03
    E_INIT4 ==> E_INIT_04
    E_INIT5 ==> E_INIT_05
    E_INIT6 ==> E_INIT_06
    E_INIT7 ==> E_INIT_07
    E_INIT8 ==> E_INIT_08
    E_INIT9 ==> E_INIT_09
    E_INIT10 ==> E_INIT_10
    E_LIST1 ==> E_LIST_1
    E_LIST2 ==> E_LIST_2
    E_LIST3 ==> E_LIST_3
    E_LIST4 ==> E_LIST_4
    E_LIST5 ==> E_LIST_5
    E_LIST6 ==> E_LIST_6
    E_MODIFY1 ==> E_MODIFY_1
    E_MODIFY2 ==> E_MODIFY_2
    E_MODIFY3 ==> E_MODIFY_3
    E_MODIFY4 ==> E_MODIFY_4
    E_MODIFY5 ==> E_MODIFY_5
    E_FPATHOPEN1 ==> E_FPATHOPEN_1
    E_FPATHOPEN2 ==> E_FPATHOPEN_2
    E_LOG1 ==> E_LOG_1
    E_LOG2 ==> E_LOG_2
    E_LOG3 ==> E_LOG_3
    E_FGETFILE1 ==> E_FGETFILE_1
    E_FGETFILE2 ==> E_FGETFILE_2
    E_FGETFILE3 ==> E_FGETFILE_3
    E_TAN3 ==> E_TAN_3
    E_TAN4 ==> E_TAN_4
    E_COT3 ==> E_COT_3
    E_COT4 ==> E_COT_4
    E_SEC3 ==> E_SEC_3
    E_CSC3 ==> E_CSC_3
    E_TANH3 ==> E_TANH_3
    E_TANH4 ==> E_TANH_4
    E_COTH3 ==> E_COTH_3
    E_COTH4 ==> E_COTH_4
    E_SECH3 ==> E_SECH_3
    E_CSCH3 ==> E_CSCH_3
    E_ASIN3 ==> E_ASIN_3
    E_ACOS3 ==> E_ACOS_3
    E_ASINH3 ==> E_ASINH_3
    E_ACOSH3 ==> E_ACOSH_3
    E_ATAN3 ==> E_ATAN_3
    E_ACOT3 ==> E_ACOT_3
    E_ASEC3 ==> E_ASEC_3
    E_ACSC3 ==> E_ACSC_3
    E_ATANH3 ==> E_ATANH_3
    E_ACOTH3 ==> E_ACOTH_3
    E_ASECH3 ==> E_ASECH_3
    E_ACSCH3 ==> E_ACSCH_3
    E_D2R1 ==> E_D2R_1
    E_D2R2 ==> E_D2R_2
    E_R2D1 ==> E_R2D_1
    E_R2D2 ==> E_R2D_2
    E_G2R1 ==> E_G2R_1
    E_G2R2 ==> E_G2R_2
    E_R2G1 ==> E_R2G_1
    E_R2G2 ==> E_R2G_2
    E_D2G1 ==> E_D2G_1
    E_G2D1 ==> E_G2D_1
    E_D2DMS1 ==> E_D2DMS_1
    E_D2DMS2 ==> E_D2DMS_2
    E_D2DMS3 ==> E_D2DMS_3
    E_D2DMS4 ==> E_D2DMS_4
    E_D2DM1 ==> E_D2DM_1
    E_D2DM2 ==> E_D2DM_2
    E_D2DM3 ==> E_D2DM_3
    E_D2DM4 ==> E_D2DM_4
    E_G2GMS1 ==> E_G2GMS_1
    E_G2GMS2 ==> E_G2GMS_2
    E_G2GMS3 ==> E_G2GMS_3
    E_G2GMS4 ==> E_G2GMS_4
    E_G2GM1 ==> E_G2GM_1
    E_G2GM2 ==> E_G2GM_2
    E_G2GM3 ==> E_G2GM_3
    E_G2GM4 ==> E_G2GM_4
    E_H2HMS1 ==> E_H2HMS_1
    E_H2HMS2 ==> E_H2HMS_2
    E_H2HMS3 ==> E_H2HMS_3
    E_H2HMS4 ==> E_H2HMS_4
    E_H2HM1 ==> E_H2HM_1
    E_H2HM2 ==> E_H2HM_2
    E_H2HM3 ==> E_H2HM_3
    E_H2HM4 ==> E_H2HM_4
    E_DMS2D1 ==> E_DMS2D_1
    E_DMS2D2 ==> E_DMS2D_2
    E_DM2D1 ==> E_DM2D_1
    E_DM2D2 ==> E_DM2D_2
    E_GMS2G1 ==> E_GMS2G_1
    E_GMS2G2 ==> E_GMS2G_2
    E_GM2G1 ==> E_GM2G_1
    E_GM2G2 ==> E_GM2G_2
    E_HMS2H1 ==> E_HMS2H_1
    E_HMS2H2 ==> E_HMS2H_2
    E_HM2H1 ==> E_HM2H_1
    E_HM2H2 ==> E_HM2H_2
    E_VERSIN1 ==> E_VERSIN_1
    E_VERSIN2 ==> E_VERSIN_2
    E_VERSIN3 ==> E_VERSIN_3
    E_AVERSIN1 ==> E_AVERSIN_1
    E_AVERSIN2 ==> E_AVERSIN_2
    E_AVERSIN3 ==> E_AVERSIN_3
    E_COVERSIN1 ==> E_COVERSIN_1
    E_COVERSIN2 ==> E_COVERSIN_2
    E_COVERSIN3 ==> E_COVERSIN_3
    E_ACOVERSIN1 ==> E_ACOVERSIN_1
    E_ACOVERSIN2 ==> E_ACOVERSIN_2
    E_ACOVERSIN3 ==> E_ACOVERSIN_3
    E_VERCOS1 ==> E_VERCOS_1
    E_VERCOS2 ==> E_VERCOS_2
    E_VERCOS3 ==> E_VERCOS_3
    E_AVERCOS1 ==> E_AVERCOS_1
    E_AVERCOS2 ==> E_AVERCOS_2
    E_AVERCOS3 ==> E_AVERCOS_3
    E_COVERCOS1 ==> E_COVERCOS_1
    E_COVERCOS2 ==> E_COVERCOS_2
    E_COVERCOS3 ==> E_COVERCOS_3
    E_ACOVERCOS1 ==> E_ACOVERCOS_1
    E_ACOVERCOS2 ==> E_ACOVERCOS_2
    E_ACOVERCOS3 ==> E_ACOVERCOS_3
    E_TAN5 ==> E_TAN_5
    E_COT5 ==> E_COT_5
    E_COT6 ==> E_COT_6
    E_SEC5 ==> E_SEC_5
    E_CSC5 ==> E_CSC_5
    E_CSC6 ==> E_CSC_6
2023-09-19 18:34:21 -07:00

12450 lines
260 KiB
C

/*
* func - built-in functions implemented here
*
* Copyright (C) 1999-2007,2018,2021-2023 David I. Bell, Landon Curt Noll and Ernest Bowen
*
* Primary author: David I. Bell
*
* Calc is open software; you can redistribute it and/or modify it under
* the terms of the version 2.1 of the GNU Lesser General Public License
* as published by the Free Software Foundation.
*
* Calc 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 Lesser General
* Public License for more details.
*
* A copy of version 2.1 of the GNU Lesser General Public License is
* distributed with calc under the filename COPYING-LGPL. You should have
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* Under source code control: 1990/02/15 01:48:15
* File existed as early as: before 1990
*
* Share and enjoy! :-) http://www.isthe.com/chongo/tech/comp/calc/
*/
#include <stdio.h>
#include <ctype.h>
#include <sys/types.h>
#include <errno.h>
#if defined(_WIN32) || defined(_WIN64)
# include <io.h>
# define _access access
#endif
#if defined(FUNCLIST)
#define CONST /* disabled for FUNCLIST in case NATIVE_CC doesn't have it */
#undef HAVE_CONST
#include "decl.h"
#else /* FUNCLIST */
#include "decl.h"
#include "have_unistd.h"
#if defined(HAVE_UNISTD_H)
#include <unistd.h>
#endif
#include "have_stdlib.h"
#if defined(HAVE_STDLIB_H)
#include <stdlib.h>
#endif
#include "have_string.h"
#if defined(HAVE_STRING_H)
#include <string.h>
#endif
#include "have_times.h"
#if defined(HAVE_TIME_H)
#include <time.h>
#endif
#if defined(HAVE_TIMES_H)
#include <times.h>
#endif
#if defined(HAVE_SYS_TIME_H)
#include <sys/time.h>
#endif
#if defined(HAVE_SYS_TIMES_H)
#include <sys/times.h>
#endif
#include "have_strdup.h"
#if !defined(HAVE_STRDUP)
# define strdup(x) calc_strdup((CONST char *)(x))
#endif
#include "have_rusage.h"
#if defined(HAVE_GETRUSAGE)
# include <sys/resource.h>
#endif
#include "have_const.h"
#include "have_unused.h"
#include "calc.h"
#include "opcodes.h"
#include "token.h"
#include "func.h"
#include "str.h"
#include "symbol.h"
#include "prime.h"
#include "file.h"
#include "zrand.h"
#include "zrandom.h"
#include "custom.h"
#include "strl.h"
#if defined(CUSTOM)
# define E_CUSTOM_ERROR E_NO_C_ARG
#else
# define E_CUSTOM_ERROR E_NO_CUSTOM
#endif
#include "errtbl.h"
#include "banned.h" /* include after system header <> includes */
/*
* forward declarations
*/
S_FUNC NUMBER *base_value(long mode, int defval);
S_FUNC int strscan(char *s, int count, VALUE **vals);
S_FUNC int filescan(FILEID id, int count, VALUE **vals);
S_FUNC VALUE f_fsize(VALUE *vp);
S_FUNC int malloced_putenv(char *str);
/*
* external declarations
*/
EXTERN char cmdbuf[]; /* command line expression */
E_FUNC void matrandperm(MATRIX *M);
E_FUNC void listrandperm(LIST *lp);
E_FUNC int idungetc(FILEID id, int ch);
E_FUNC LIST* associndices(ASSOC *ap, long index);
E_FUNC LIST* matindices(MATRIX *mp, long index);
/*
* malloced environment storage
*/
#define ENV_POOL_CHUNK (1<8) /* env_pool elements to allocate at a time */
struct env_pool {
char *getenv; /* what getenv() would return, NULL => unused */
char *putenv; /* pointer given to putenv() */
};
STATIC int env_pool_cnt = 0; /* number of env_pool elements in use */
STATIC int env_pool_max = 0; /* number of env_pool elements allocated */
STATIC struct env_pool *e_pool = NULL; /* env_pool elements */
/*
* constants used for hours or degrees conversion functions
*/
STATIC HALF _nineval_[] = { 9 };
STATIC HALF _twentyfourval_[] = { 24 };
STATIC HALF _threesixtyval_[] = { 360 };
STATIC HALF _fourhundredval_[] = { 400 };
STATIC NUMBER _qtendivnine_ = { { _tenval_, 1, 0 },
{ _nineval_, 1, 0 }, 1, NULL };
STATIC NUMBER _qninedivten_ = { { _nineval_, 1, 0 },
{ _tenval_, 1, 0 }, 1, NULL };
STATIC NUMBER _qtwentyfour = { { _twentyfourval_, 1, 0 },
{ _oneval_, 1, 0 }, 1, NULL };
STATIC NUMBER _qthreesixty = { { _threesixtyval_, 1, 0 },
{ _oneval_, 1, 0 }, 1, NULL };
STATIC NUMBER _qfourhundred = { { _fourhundredval_, 1, 0 },
{ _oneval_, 1, 0 }, 1, NULL };
/*
* user-defined error strings
*/
STATIC short nexterrnum = E__USERDEF;
STATIC STRINGHEAD newerrorstr;
#endif /* !FUNCLIST */
/*
* arg count definitions
*/
#define IN 1024 /* maximum number of arguments */
#define FE 0x01 /* flag to indicate default epsilon argument */
#define FA 0x02 /* preserve addresses of variables */
/*
* builtins - List of primitive built-in functions
*/
typedef union {
char *null; /* no b_numfunc function */
NUMBER *(*numfunc_0)(void);
#if !defined(FUNCLIST)
NUMBER *(*numfunc_1)(NUMBER *);
NUMBER *(*numfunc_2)(NUMBER *, NUMBER *);
NUMBER *(*numfunc_3)(NUMBER *, NUMBER *, NUMBER *);
NUMBER *(*numfunc_4)(NUMBER *, NUMBER *, NUMBER *, NUMBER *);
NUMBER *(*numfunc_cnt)(int, NUMBER **);
#endif /* !FUNCLIST */
} numfunc;
typedef union {
char *null; /* no b_valfunc function */
VALUE (*valfunc_0)(void);
#if !defined(FUNCLIST)
VALUE (*valfunc_1)(VALUE *);
VALUE (*valfunc_2)(VALUE *, VALUE *);
VALUE (*valfunc_3)(VALUE *, VALUE *, VALUE *);
VALUE (*valfunc_4)(VALUE *, VALUE *, VALUE *, VALUE *);
VALUE (*valfunc_cnt)(int, VALUE **);
#endif /* !FUNCLIST */
} valfunc;
struct builtin {
char *b_name; /* name of built-in function */
short b_minargs; /* minimum number of arguments */
short b_maxargs; /* maximum number of arguments */
short b_flags; /* special handling flags */
short b_opcode; /* opcode which makes the call quick */
numfunc b_numfunc; /* routine to calculate numeric function */
valfunc b_valfunc; /* routine to calculate general values */
char *b_desc; /* description of function */
};
#if !defined(FUNCLIST)
/*
* verify_eps - verify that the eps argument is a valid error value
*
* The eps argument, when given to a builtin function, overrides
* the global epsilon value. As such, the numeric value of eps must be:
*
* 0 < eps < 1
*
* given:
* veps a eps VALUE passed to a builtin function
*
* returns:
* true veps is a non-NULL pointer to a VALUE, and
* VALUE type is V_NUM,
* eps value is 0 < eps < 1
* false otherwise
*/
S_FUNC bool
verify_eps(VALUE CONST *veps)
{
NUMBER *eps; /* VALUE as a NUMBER */
/*
* firewall - must be a non-NULL VALUE ptr for a V_NUM
*/
if (veps == NULL) {
return false;
}
if (veps->v_type != V_NUM) {
return false;
}
/*
* numeric value must be valid for an epsilon value
*
* 0 < eps < 1
*/
eps = veps->v_num;
if (check_epsilon(eps) == false) {
return false;
}
return true;
}
/*
* name_newerrorstr - obtain the name string for a user-described error code
*
* given:
* errnum errnum code to convert
*
* returns:
* != NULL ==> non-empty name string for a user-described error
* == NULL ==> errnum is not valid, or name string is empty, or name string not found
*/
char *
name_newerrorstr(int errnum)
{
char *cp; /* name string lookup result */
/*
* firewall
*/
if (is_valid_errnum(errnum) == false) {
/* errnum is not a valid code */
return NULL;
}
/*
* case: errnum is not a user-described code
*/
if (errnum < E__USERDEF || errnum > E__USERMAX) {
/* errnum is not a user-described code */
return NULL;
}
/*
* case: errnum is outside the current range of user-described codes
*/
if (errnum >= nexterrnum) {
/* errnum is refers to an unassigned user-described code */
return NULL;
}
/*
* attempt to fetch the name string for a user-described error code
*/
cp = namestr(&newerrorstr, errnum - E__USERDEF);
if (cp == NULL || cp[0] == '\0') {
/* name string was not found or was empty for the user-described error code */
return NULL;
}
/*
* return the name string for the user-described error code
*/
return cp;
}
S_FUNC VALUE
f_eval(VALUE *vp)
{
FUNC *oldfunc;
FUNC *newfunc;
VALUE result;
char *str;
size_t num;
long temp_stoponerror; /* temp value of stoponerror */
if (vp->v_type != V_STR)
return error_value(E_EVAL_2);
str = vp->v_str->s_str;
num = vp->v_str->s_len;
switch (openstring(str, num)) {
case -2:
return error_value(E_EVAL_3);
case -1:
return error_value(E_EVAL_4);
}
oldfunc = curfunc;
enterfilescope();
temp_stoponerror = stoponerror;
stoponerror = -1;
if (evaluate(true)) {
stoponerror = temp_stoponerror;
closeinput();
exitfilescope();
freevalue(stack--);
newfunc = curfunc;
curfunc = oldfunc;
result = newfunc->f_savedvalue;
newfunc->f_savedvalue.v_type = V_NULL;
newfunc->f_savedvalue.v_subtype = V_NOSUBTYPE;
freenumbers(newfunc);
if (newfunc != oldfunc)
free(newfunc);
return result;
}
stoponerror = temp_stoponerror;
closeinput();
exitfilescope();
newfunc = curfunc;
curfunc = oldfunc;
freevalue(&newfunc->f_savedvalue);
newfunc->f_savedvalue.v_type = V_NULL;
newfunc->f_savedvalue.v_subtype = V_NOSUBTYPE;
freenumbers(newfunc);
if (newfunc != oldfunc)
free(newfunc);
return error_value(E_EVAL);
}
S_FUNC VALUE
f_prompt(VALUE *vp)
{
VALUE result;
char *cp;
char *newcp;
size_t len;
/* initialize VALUE */
result.v_type = V_STR;
result.v_subtype = V_NOSUBTYPE;
openterminal();
printvalue(vp, PRINT_SHORT);
math_flush();
cp = nextline();
closeinput();
if (cp == NULL) {
result.v_type = V_NULL;
return result;
}
if (*cp == '\0') {
result.v_str = slink(&_nullstring_);
return result;
}
len = strlen(cp);
newcp = (char *) malloc(len + 1);
if (newcp == NULL) {
math_error("Cannot allocate string");
not_reached();
}
strlcpy(newcp, cp, len+1);
result.v_str = makestring(newcp);
return result;
}
S_FUNC VALUE
f_display(int count, VALUE **vals)
{
LEN oldvalue;
VALUE res;
/* initialize VALUE */
res.v_type = V_NUM;
res.v_subtype = V_NOSUBTYPE;
oldvalue = conf->outdigits;
if (count > 0) {
if (vals[0]->v_type != V_NUM || qisfrac(vals[0]->v_num) ||
qisneg(vals[0]->v_num) || zge31b(vals[0]->v_num->num))
fprintf(stderr,
"Out-of-range arg for display ignored\n");
else
conf->outdigits = (LEN) qtoi(vals[0]->v_num);
}
res.v_num = itoq((long) oldvalue);
return res;
}
/*ARGSUSED*/
S_FUNC VALUE
f_null(int UNUSED(count), VALUE **UNUSED(vals))
{
VALUE res;
/* initialize VALUE */
res.v_type = V_NULL;
res.v_subtype = V_NOSUBTYPE;
return res;
}
S_FUNC VALUE
f_str(VALUE *vp)
{
VALUE result;
char *cp;
/* initialize VALUE */
result.v_type = V_STR;
result.v_subtype = V_NOSUBTYPE;
switch (vp->v_type) {
case V_STR:
result.v_str = makenewstring(vp->v_str->s_str);
break;
case V_NULL:
result.v_str = slink(&_nullstring_);
break;
case V_OCTET:
result.v_str = charstring(*vp->v_octet);
break;
case V_NUM:
math_divertio();
qprintnum(vp->v_num, MODE_DEFAULT, conf->outdigits);
cp = math_getdivertedio();
result.v_str = makestring(cp);
break;
case V_COM:
math_divertio();
comprint(vp->v_com);
cp = math_getdivertedio();
result.v_str = makestring(cp);
break;
default:
return error_value(E_STR);
}
return result;
}
S_FUNC VALUE
f_estr(VALUE *vp)
{
VALUE result;
char *cp;
/* initialize result */
result.v_type = V_STR;
result.v_subtype = V_NOSUBTYPE;
math_divertio();
printestr(vp);
cp = math_getdivertedio();
result.v_str = makestring(cp);
return result;
}
S_FUNC VALUE
f_name(VALUE *vp)
{
VALUE result;
char *cp;
char *name;
/* initialize VALUE */
result.v_type = V_STR;
result.v_subtype = V_NOSUBTYPE;
switch (vp->v_type) {
case V_NBLOCK:
result.v_type = V_STR;
result.v_str = makenewstring(vp->v_nblock->name);
return result;
case V_FILE:
name = findfname(vp->v_file);
if (name == NULL) {
result.v_type = V_NULL;
return result;
}
math_divertio();
math_str(name);
cp = math_getdivertedio();
break;
default:
result.v_type = V_NULL;
return result;
}
result.v_str = makestring(cp);
return result;
}
S_FUNC VALUE
f_poly(int count, VALUE **vals)
{
VALUE *x;
VALUE result, tmp;
LIST *clist, *lp;
/* initialize VALUEs */
result.v_subtype = V_NOSUBTYPE;
tmp.v_subtype = V_NOSUBTYPE;
if (vals[0]->v_type == V_LIST) {
clist = vals[0]->v_list;
lp = listalloc();
while (--count > 0) {
if ((*++vals)->v_type == V_LIST)
insertitems(lp, (*vals)->v_list);
else
insertlistlast(lp, *vals);
}
if (!evalpoly(clist, lp->l_first, &result)) {
result.v_type = V_NUM;
result.v_num = qlink(&_qzero_);
}
listfree(lp);
return result;
}
x = vals[--count];
copyvalue(*vals++, &result);
while (--count > 0) {
mulvalue(&result, x, &tmp);
freevalue(&result);
addvalue(*vals++, &tmp, &result);
freevalue(&tmp);
}
return result;
}
S_FUNC NUMBER *
f_mne(NUMBER *val1, NUMBER *val2, NUMBER *val3)
{
NUMBER *tmp, *res;
tmp = qsub(val1, val2);
res = itoq((long) !qdivides(tmp, val3));
qfree(tmp);
return res;
}
S_FUNC NUMBER *
f_isrel(NUMBER *val1, NUMBER *val2)
{
if (qisfrac(val1) || qisfrac(val2)) {
math_error("Non-integer for isrel");
not_reached();
}
return itoq((long) zrelprime(val1->num, val2->num));
}
S_FUNC NUMBER *
f_issquare(NUMBER *vp)
{
return itoq((long) qissquare(vp));
}
S_FUNC NUMBER *
f_isprime(int count, NUMBER **vals)
{
NUMBER *err; /* error return, NULL => use math_error */
/* determine the way we report problems */
if (count == 2) {
if (qisfrac(vals[1])) {
math_error("2nd isprime arg must be an integer");
not_reached();
}
err = vals[1];
} else {
err = NULL;
}
/* firewall - must be an integer */
if (qisfrac(vals[0])) {
if (err) {
return qlink(err);
}
math_error("non-integral arg for builtin function isprime");
not_reached();
}
/* test the integer */
switch (zisprime(vals[0]->num)) {
case 0: return qlink(&_qzero_);
case 1: return qlink(&_qone_);
}
/* error return */
if (!err) {
math_error("isprime argument is an odd value > 2^32");
not_reached();
}
return qlink(err);
}
S_FUNC NUMBER *
f_nprime(int count, NUMBER **vals)
{
NUMBER *err; /* error return, NULL => use math_error */
FULL nxt_prime; /* next prime or 0 */
/* determine the way we report problems */
if (count == 2) {
if (qisfrac(vals[1])) {
math_error("2nd nextprime arg must be an integer");
not_reached();
}
err = vals[1];
} else {
err = NULL;
}
/* firewall - must be an integer */
if (qisfrac(vals[0])) {
if (err) {
return qlink(err);
}
math_error("non-integral arg 1 for builtin function nextprime");
not_reached();
}
/* test the integer */
nxt_prime = znprime(vals[0]->num);
if (nxt_prime > 1) {
return utoq(nxt_prime);
} else if (nxt_prime == 0) {
/* return 2^32+15 */
return qlink(&_nxtprime_);
}
/* error return */
if (!err) {
math_error("nextprime arg 1 is >= 2^32");
not_reached();
}
return qlink(err);
}
S_FUNC NUMBER *
f_pprime(int count, NUMBER **vals)
{
NUMBER *err; /* error return, NULL => use math_error */
FULL prev_prime; /* previous prime or 0 */
/* determine the way we report problems */
if (count == 2) {
if (qisfrac(vals[1])) {
math_error("2nd prevprime arg must be an integer");
not_reached();
}
err = vals[1];
} else {
err = NULL;
}
/* firewall - must be an integer */
if (qisfrac(vals[0])) {
if (err) {
return qlink(err);
}
math_error("non-integral arg 1 for builtin function prevprime");
not_reached();
}
/* test the integer */
prev_prime = zpprime(vals[0]->num);
if (prev_prime > 1) {
return utoq(prev_prime);
}
if (prev_prime == 0) {
return qlink(&_qzero_);
}
/* error return */
if (!err) {
if (prev_prime == 0) {
math_error("prevprime arg 1 is <= 2");
not_reached();
} else {
math_error("prevprime arg 1 is >= 2^32");
not_reached();
}
}
return qlink(err);
}
S_FUNC NUMBER *
f_factor(int count, NUMBER **vals)
{
NUMBER *err; /* error return, NULL => use math_error */
ZVALUE limit; /* highest prime factor in search */
ZVALUE n; /* number to factor */
NUMBER *factor; /* the prime factor found */
int res; /* -1 => error, 0 => not found, 1 => factor found */
/*
* parse args
*/
if (count == 3) {
if (qisfrac(vals[2])) {
math_error("3rd factor arg must be an integer");
not_reached();
}
err = vals[2];
} else {
err = NULL;
}
if (count >= 2) {
if (qisfrac(vals[1])) {
if (err) {
return qlink(err);
}
math_error("non-integral arg 2 for builtin factor");
not_reached();
}
limit = vals[1]->num;
} else {
/* default limit is 2^32-1 */
utoz((FULL)0xffffffff, &limit);
}
if (qisfrac(vals[0])) {
if (count < 2)
zfree(limit);
if (err) {
return qlink(err);
}
math_error("non-integral arg 1 for builtin pfactor");
not_reached();
}
n = vals[0]->num;
/*
* find the smallest prime factor in the range
*/
factor = qalloc();
res = zfactor(n, limit, &(factor->num));
if (res < 0) {
/* error processing */
if (err) {
return qlink(err);
}
math_error("limit >= 2^32 for builtin factor");
not_reached();
} else if (res == 0) {
if (count < 2)
zfree(limit);
/* no factor found - qalloc set factor to 1, return 1 */
return factor;
}
/*
* return the factor found
*/
if (count < 2)
zfree(limit);
return factor;
}
S_FUNC NUMBER *
f_pix(int count, NUMBER **vals)
{
NUMBER *err; /* error return, NULL => use math_error */
long value; /* primes <= x, or 0 ==> error */
/* determine the way we report problems */
if (count == 2) {
if (qisfrac(vals[1])) {
math_error("2nd pix arg must be an integer");
not_reached();
}
err = vals[1];
} else {
err = NULL;
}
/* firewall - must be an integer */
if (qisfrac(vals[0])) {
if (err) {
return qlink(err);
}
math_error("non-integral arg 1 for builtin function pix");
not_reached();
}
/* determine the number of primes <= x */
value = zpix(vals[0]->num);
if (value >= 0) {
return utoq(value);
}
/* error return */
if (!err) {
math_error("pix arg 1 is >= 2^32");
not_reached();
}
return qlink(err);
}
S_FUNC NUMBER *
f_prevcand(int count, NUMBER **vals)
{
ZVALUE zmodulus;
ZVALUE zresidue;
ZVALUE zskip;
ZVALUE *zcount = NULL; /* ptest trial count */
ZVALUE tmp;
NUMBER *ans; /* candidate for primality */
zmodulus = _one_;
zresidue = _zero_;
zskip = _one_;
/*
* check on the number of args passed and that args passed are ints
*/
switch (count) {
case 5:
if (!qisint(vals[4])) {
math_error( "prevcand 5th arg must both be integer");
not_reached();
}
zmodulus = vals[4]->num;
/*FALLTHRU*/
case 4:
if (!qisint(vals[3])) {
math_error( "prevcand 4th arg must both be integer");
not_reached();
}
zresidue = vals[3]->num;
/*FALLTHRU*/
case 3:
if (!qisint(vals[2])) {
math_error(
"prevcand skip arg (3rd) must be an integer or omitted");
not_reached();
}
zskip = vals[2]->num;
/*FALLTHRU*/
case 2:
if (!qisint(vals[1])) {
math_error(
"prevcand count arg (2nd) must be an integer or omitted");
not_reached();
}
zcount = &vals[1]->num;
/*FALLTHRU*/
case 1:
if (!qisint(vals[0])) {
math_error(
"prevcand search arg (1st) must be an integer");
not_reached();
}
break;
default:
math_error("invalid number of args passed to prevcand");
not_reached();
break;
}
if (zcount == NULL) {
count = 1; /* default is 1 ptest */
} else {
if (zge24b(*zcount)) {
math_error("prevcand count arg (2nd) must be < 2^24");
not_reached();
}
count = ztoi(*zcount);
}
/*
* find the candidate
*/
if (zprevcand(vals[0]->num, count, zskip, zresidue, zmodulus, &tmp)) {
ans = qalloc();
ans->num = tmp;
return ans;
}
return qlink(&_qzero_);
}
S_FUNC NUMBER *
f_nextcand(int count, NUMBER **vals)
{
ZVALUE zmodulus;
ZVALUE zresidue;
ZVALUE zskip;
ZVALUE *zcount = NULL; /* ptest trial count */
ZVALUE tmp;
NUMBER *ans; /* candidate for primality */
zmodulus = _one_;
zresidue = _zero_;
zskip = _one_;
/*
* check on the number of args passed and that args passed are ints
*/
switch (count) {
case 5:
if (!qisint(vals[4])) {
math_error(
"nextcand 5th args must be integer");
not_reached();
}
zmodulus = vals[4]->num;
/*FALLTHRU*/
case 4:
if (!qisint(vals[3])) {
math_error(
"nextcand 5th args must be integer");
not_reached();
}
zresidue = vals[3]->num;
/*FALLTHRU*/
case 3:
if (!qisint(vals[2])) {
math_error(
"nextcand skip arg (3rd) must be an integer or omitted");
not_reached();
}
zskip = vals[2]->num;
/*FALLTHRU*/
case 2:
if (!qisint(vals[1])) {
math_error(
"nextcand count arg (2nd) must be an integer or omitted");
not_reached();
}
zcount = &vals[1]->num;
/*FALLTHRU*/
case 1:
if (!qisint(vals[0])) {
math_error(
"nextcand search arg (1st) must be an integer");
not_reached();
}
break;
default:
math_error("invalid number of args passed to nextcand");
not_reached();
}
/*
* check ranges on integers passed
*/
if (zcount == NULL) {
count = 1; /* default is 1 ptest */
} else {
if (zge24b(*zcount)) {
math_error("prevcand count arg (2nd) must be < 2^24");
not_reached();
}
count = ztoi(*zcount);
}
/*
* find the candidate
*/
if (znextcand(vals[0]->num, count, zskip, zresidue, zmodulus, &tmp)) {
ans = qalloc();
ans->num = tmp;
return ans;
}
return qlink(&_qzero_);
}
S_FUNC NUMBER *
f_seed(void)
{
return pseudo_seed();
}
S_FUNC NUMBER *
f_rand(int count, NUMBER **vals)
{
NUMBER *ans;
/* parse args */
switch (count) {
case 0: /* rand() == rand(2^64) */
/* generate an subtractive 100 shuffle pseudo-random number */
ans = qalloc();
zrand(SBITS, &ans->num);
break;
case 1: /* rand(limit) */
if (!qisint(vals[0])) {
math_error("rand limit must be an integer");
not_reached();
}
if (zislezero(vals[0]->num)) {
math_error("rand limit must > 0");
not_reached();
}
ans = qalloc();
zrandrange(_zero_, vals[0]->num, &ans->num);
break;
case 2: /* rand(low, limit) */
/* firewall */
if (!qisint(vals[0]) || !qisint(vals[1])) {
math_error("rand range must be integers");
not_reached();
}
ans = qalloc();
zrandrange(vals[0]->num, vals[1]->num, &ans->num);
break;
default:
math_error("invalid number of args passed to rand");
not_reached();
return NULL;
}
/* return the subtractive 100 shuffle pseudo-random number */
return ans;
}
S_FUNC NUMBER *
f_randbit(int count, NUMBER **vals)
{
NUMBER *ans;
ZVALUE ztmp;
long cnt; /* bits needed or skipped */
/* parse args */
if (count == 0) {
zrand(1, &ztmp);
ans = ziszero(ztmp) ? qlink(&_qzero_) : qlink(&_qone_);
zfree(ztmp);
return ans;
}
/*
* firewall
*/
if (!qisint(vals[0])) {
math_error("rand bit count must be an integer");
not_reached();
}
if (zge31b(vals[0]->num)) {
math_error("huge rand bit count");
not_reached();
}
/*
* generate an subtractive 100 shuffle pseudo-random number or skip random bits
*/
ans = qalloc();
cnt = ztolong(vals[0]->num);
if (zisneg(vals[0]->num)) {
/* skip bits */
zrandskip(cnt);
itoz(cnt, &ans->num);
} else {
/* generate bits */
zrand(cnt, &ans->num);
}
/*
* return the subtractive 100 shuffle pseudo-random number
*/
return ans;
}
S_FUNC VALUE
f_srand(int count, VALUE **vals)
{
VALUE result;
/* initialize VALUE */
result.v_type = V_RAND;
result.v_subtype = V_NOSUBTYPE;
/* parse args */
switch (count) {
case 0:
/* get the current subtractive 100 shuffle pseudo-random number generator state */
result.v_rand = zsrand(NULL, NULL);
break;
case 1:
switch (vals[0]->v_type) {
case V_NUM: /* srand(seed) */
/* seed subtractive 100 shuffle pseudo-random number generator and return previous state */
if (!qisint(vals[0]->v_num)) {
math_error(
"srand number seed must be an integer");
not_reached();
}
result.v_rand = zsrand(&vals[0]->v_num->num, NULL);
break;
case V_RAND: /* srand(state) */
/* set subtractive 100 shuffle pseudo-random number generator state and return previous state */
result.v_rand = zsetrand(vals[0]->v_rand);
break;
case V_MAT:
/* load subtractive 100 table and return prev state */
result.v_rand = zsrand(NULL, vals[0]->v_mat);
break;
default:
math_error("illegal type of arg passed to srand()");
not_reached();
break;
}
break;
default:
math_error("bad arg count to srand()");
not_reached();
break;
}
/* return the current state */
return result;
}
S_FUNC NUMBER *
f_random(int count, NUMBER **vals)
{
NUMBER *ans;
/* parse args */
switch (count) {
case 0: /* random() == random(2^64) */
/* generate a Blum-Blum-Shub random number */
ans = qalloc();
zrandom(SBITS, &ans->num);
break;
case 1: /* random(limit) */
if (!qisint(vals[0])) {
math_error("random limit must be an integer");
not_reached();
}
if (zislezero(vals[0]->num)) {
math_error("random limit must > 0");
not_reached();
}
ans = qalloc();
zrandomrange(_zero_, vals[0]->num, &ans->num);
break;
case 2: /* random(low, limit) */
/* firewall */
if (!qisint(vals[0]) || !qisint(vals[1])) {
math_error("random range must be integers");
not_reached();
}
ans = qalloc();
zrandomrange(vals[0]->num, vals[1]->num, &ans->num);
break;
default:
math_error("invalid number of args passed to random");
not_reached();
return NULL;
}
/* return the Blum-Blum-Shub random number */
return ans;
}
S_FUNC NUMBER *
f_randombit(int count, NUMBER **vals)
{
NUMBER *ans;
ZVALUE ztmp;
long cnt; /* bits needed or skipped */
/* parse args */
ztmp.len = 0; /* paranoia */
ztmp.v = NULL;
ztmp.sign = 0;
if (count == 0) {
zrandom(1, &ztmp);
ans = ziszero(ztmp) ? qlink(&_qzero_) : qlink(&_qone_);
zfree(ztmp);
return ans;
}
/*
* firewall
*/
if (!qisint(vals[0])) {
math_error("random bit count must be an integer");
not_reached();
}
if (zge31b(vals[0]->num)) {
math_error("huge random bit count");
not_reached();
}
/*
* generate a Blum-Blum-Shub random number or skip random bits
*/
ans = qalloc();
cnt = ztolong(vals[0]->num);
if (zisneg(vals[0]->num)) {
/* skip bits */
zrandomskip(cnt);
itoz(cnt, &ans->num);
} else {
/* generate bits */
zrandom(cnt, &ans->num);
}
/*
* return the Blum-Blum-Shub random number
*/
return ans;
}
S_FUNC VALUE
f_srandom(int count, VALUE **vals)
{
VALUE result;
/* initialize VALUE */
result.v_type = V_RANDOM;
result.v_subtype = V_NOSUBTYPE;
/* parse args */
switch (count) {
case 0: /* srandom() */
/* get the current random state */
result.v_random = zsetrandom(NULL);
break;
case 1: /* srandom(seed) or srandom(state) */
switch (vals[0]->v_type) {
case V_NUM: /* srand(seed) */
/* seed Blum and return previous state */
if (!qisint(vals[0]->v_num)) {
math_error(
"srandom number seed must be an integer");
not_reached();
}
result.v_random = zsrandom1(vals[0]->v_num->num, true);
break;
case V_RANDOM: /* srandom(state) */
/* set subtractive 100 shuffle pseudo-random number generator state and return previous state */
result.v_random = zsetrandom(vals[0]->v_random);
break;
default:
math_error("illegal type of arg passed to srandom()");
not_reached();
break;
}
break;
case 2: /* srandom(seed, newn) */
if (vals[0]->v_type != V_NUM || !qisint(vals[0]->v_num)) {
math_error("srandom seed must be an integer");
not_reached();
}
if (vals[1]->v_type != V_NUM || !qisint(vals[1]->v_num)) {
math_error("srandom Blum modulus must be an integer");
not_reached();
}
result.v_random = zsrandom2(vals[0]->v_num->num,
vals[1]->v_num->num);
break;
case 4: /* srandom(seed, ip, iq, trials) */
if (vals[0]->v_type != V_NUM || !qisint(vals[0]->v_num)) {
math_error("srandom seed must be an integer");
not_reached();
}
if (vals[1]->v_type != V_NUM || !qisint(vals[1]->v_num)) {
math_error("srandom 2nd arg must be an integer");
not_reached();
}
if (vals[2]->v_type != V_NUM || !qisint(vals[2]->v_num)) {
math_error("srandom 3rd arg must be an integer");
not_reached();
}
if (vals[3]->v_type != V_NUM || !qisint(vals[3]->v_num)) {
math_error("srandom 4th arg must be an integer");
not_reached();
}
if (zge24b(vals[3]->v_num->num)) {
math_error("srandom trials count is excessive");
not_reached();
}
result.v_random = zsrandom4(vals[0]->v_num->num,
vals[1]->v_num->num,
vals[2]->v_num->num,
ztoi(vals[3]->v_num->num));
break;
default:
math_error("bad arg count to srandom()");
not_reached();
break;
}
/* return the current state */
return result;
}
S_FUNC NUMBER *
f_primetest(int count, NUMBER **vals)
{
/* parse args */
switch (count) {
case 1: qlink(&_qone_);
qlink(&_qone_);
return itoq((long) qprimetest(vals[0], &_qone_, &_qone_));
case 2: qlink(&_qone_);
return itoq((long) qprimetest(vals[0], vals[1], &_qone_));
default: return itoq((long) qprimetest(vals[0], vals[1], vals[2]));
}
}
S_FUNC VALUE
f_setbit(int count, VALUE **vals)
{
bool r;
long index;
VALUE result;
/* initialize VALUE */
result.v_type = V_NULL;
result.v_subtype = V_NOSUBTYPE;
r = (count == 3) ? testvalue(vals[2]) : 1;
if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num))
return error_value(E_SETBIT_1);
if (zge31b(vals[1]->v_num->num))
return error_value(E_SETBIT_2);
if (vals[0]->v_type != V_STR)
return error_value(E_SETBIT_3);
index = qtoi(vals[1]->v_num);
if (stringsetbit(vals[0]->v_str, index, r))
return error_value(E_SETBIT_2);
return result;
}
S_FUNC VALUE
f_digit(int count, VALUE **vals)
{
VALUE res;
ZVALUE base;
if (vals[0]->v_type != V_NUM)
return error_value(E_DGT_1);
if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num))
return error_value(E_DGT_2);
if (count == 3) {
if (vals[2]->v_type != V_NUM || qisfrac(vals[2]->v_num))
return error_value(E_DGT_3);
base = vals[2]->v_num->num;
} else {
base = _ten_;
}
res.v_type = V_NUM;
res.v_subtype = V_NOSUBTYPE;
res.v_num = qdigit(vals[0]->v_num, vals[1]->v_num->num, base);
if (res.v_num == NULL)
return error_value(E_DGT_3);
return res;
}
S_FUNC VALUE
f_digits(int count, VALUE **vals)
{
ZVALUE base;
VALUE res;
if (vals[0]->v_type != V_NUM)
return error_value(E_DGTS_1);
if (count > 1) {
if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num)
|| qiszero(vals[1]->v_num) || qisunit(vals[1]->v_num))
return error_value(E_DGTS_2);
base = vals[1]->v_num->num;
} else {
base = _ten_;
}
res.v_type = V_NUM;
res.v_subtype = V_NOSUBTYPE;
res.v_num = itoq(qdigits(vals[0]->v_num, base));
return res;
}
S_FUNC VALUE
f_places(int count, VALUE **vals)
{
long places;
VALUE res;
if (vals[0]->v_type != V_NUM)
return error_value(E_PLCS_1);
if (count > 1) {
if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num))
return error_value(E_PLCS_2);
places = qplaces(vals[0]->v_num, vals[1]->v_num->num);
if (places == -2)
return error_value(E_PLCS_2);
} else
places = qdecplaces(vals[0]->v_num);
res.v_type = V_NUM;
res.v_subtype = V_NOSUBTYPE;
res.v_num = itoq(places);
return res;
}
S_FUNC NUMBER *
f_popcnt(int count, NUMBER **vals)
{
int bitval = 1;
/*
* parse args
*/
if (count == 2 && qiszero(vals[1])) {
bitval = 0;
}
/*
* count bit values
*/
if (qisint(vals[0])) {
return itoq(zpopcnt(vals[0]->num, bitval));
} else {
return itoq(zpopcnt(vals[0]->num, bitval) +
zpopcnt(vals[0]->den, bitval));
}
}
S_FUNC VALUE
f_xor(int count, VALUE **vals)
{
NUMBER *q, *qtmp;
STRING *s, *stmp;
VALUE result;
int i;
int type;
type = vals[0]->v_type;
result.v_type = type;
result.v_subtype = vals[0]->v_subtype;
for (i = 1; i < count; i++) {
if (vals[i]->v_type != type)
return error_value(E_XOR_1);
}
switch (type) {
case V_NUM:
q = qlink(vals[0]->v_num);
for (i = 1; i < count; i++) {
qtmp = qxor(q, vals[i]->v_num);
qfree(q);
q = qtmp;
}
result.v_num = q;
break;
case V_STR:
s = slink(vals[0]->v_str);
for (i = 1; i < count; i++) {
stmp = stringxor(s, vals[i]->v_str);
sfree(s);
s = stmp;
}
result.v_str = s;
break;
default:
return error_value(E_XOR_2);
}
return result;
}
VALUE
minlistitems(LIST *lp)
{
LISTELEM *ep;
VALUE *vp;
VALUE term;
VALUE rel;
VALUE min;
/* initialize VALUEs */
min.v_type = V_NULL;
min.v_subtype = V_NOSUBTYPE;
term.v_type = V_NULL;
term.v_subtype = V_NOSUBTYPE;
for (ep = lp->l_first; ep; ep = ep->e_next) {
vp = &ep->e_value;
switch(vp->v_type) {
case V_LIST:
term = minlistitems(vp->v_list);
break;
case V_OBJ:
term = objcall(OBJ_MIN, vp,
NULL_VALUE, NULL_VALUE);
break;
default:
copyvalue(vp, &term);
}
if (min.v_type == V_NULL) {
min = term;
continue;
}
if (term.v_type == V_NULL)
continue;
relvalue(&term, &min, &rel);
if (rel.v_type != V_NUM) {
freevalue(&term);
freevalue(&min);
freevalue(&rel);
return error_value(E_LISTMIN);
}
if (qisneg(rel.v_num)) {
freevalue(&min);
min = term;
}
else
freevalue(&term);
freevalue(&rel);
}
return min;
}
VALUE
maxlistitems(LIST *lp)
{
LISTELEM *ep;
VALUE *vp;
VALUE term;
VALUE rel;
VALUE max;
/* initialize VALUEs */
max.v_type = V_NULL;
max.v_subtype = V_NOSUBTYPE;
term.v_type = V_NULL;
term.v_subtype = V_NOSUBTYPE;
for (ep = lp->l_first; ep; ep = ep->e_next) {
vp = &ep->e_value;
switch(vp->v_type) {
case V_LIST:
term = maxlistitems(vp->v_list);
break;
case V_OBJ:
term = objcall(OBJ_MAX, vp,
NULL_VALUE, NULL_VALUE);
break;
default:
copyvalue(vp, &term);
}
if (max.v_type == V_NULL) {
max = term;
continue;
}
if (term.v_type == V_NULL)
continue;
relvalue(&max, &term, &rel);
if (rel.v_type != V_NUM) {
freevalue(&max);
freevalue(&term);
freevalue(&rel);
return error_value(E_LISTMAX);
}
if (qisneg(rel.v_num)) {
freevalue(&max);
max = term;
}
else
freevalue(&term);
freevalue(&rel);
}
return max;
}
S_FUNC VALUE
f_min(int count, VALUE **vals)
{
VALUE min;
VALUE term;
VALUE *vp;
VALUE rel;
/* initialize VALUEs */
min.v_type = V_NULL;
min.v_subtype = V_NOSUBTYPE;
term.v_type = V_NULL;
term.v_subtype = V_NOSUBTYPE;
while (count-- > 0) {
vp = *vals++;
switch(vp->v_type) {
case V_LIST:
term = minlistitems(vp->v_list);
break;
case V_OBJ:
term = objcall(OBJ_MIN, vp,
NULL_VALUE, NULL_VALUE);
break;
default:
copyvalue(vp, &term);
}
if (min.v_type == V_NULL) {
min = term;
continue;
}
if (term.v_type == V_NULL)
continue;
if (term.v_type < 0) {
freevalue(&min);
return term;
}
relvalue(&term, &min, &rel);
if (rel.v_type != V_NUM) {
freevalue(&min);
freevalue(&term);
freevalue(&rel);
return error_value(E_MIN);
}
if (qisneg(rel.v_num)) {
freevalue(&min);
min = term;
} else {
freevalue(&term);
}
freevalue(&rel);
}
return min;
}
S_FUNC VALUE
f_max(int count, VALUE **vals)
{
VALUE max;
VALUE term;
VALUE *vp;
VALUE rel;
/* initialize VALUEs */
max.v_type = V_NULL;
max.v_subtype = V_NOSUBTYPE;
term.v_type = V_NULL;
term.v_subtype = V_NOSUBTYPE;
while (count-- > 0) {
vp = *vals++;
switch(vp->v_type) {
case V_LIST:
term = maxlistitems(vp->v_list);
break;
case V_OBJ:
term = objcall(OBJ_MAX, vp,
NULL_VALUE, NULL_VALUE);
break;
default:
copyvalue(vp, &term);
}
if (max.v_type == V_NULL) {
max = term;
continue;
}
if (term.v_type == V_NULL)
continue;
if (term.v_type < 0) {
freevalue(&max);
return term;
}
relvalue(&max, &term, &rel);
if (rel.v_type != V_NUM) {
freevalue(&max);
freevalue(&term);
freevalue(&rel);
return error_value(E_MAX);
}
if (qisneg(rel.v_num)) {
freevalue(&max);
max = term;
} else {
freevalue(&term);
}
freevalue(&rel);
}
return max;
}
S_FUNC NUMBER *
f_gcd(int count, NUMBER **vals)
{
NUMBER *val, *tmp;
val = qqabs(*vals);
while (--count > 0) {
tmp = qgcd(val, *++vals);
qfree(val);
val = tmp;
}
return val;
}
S_FUNC NUMBER *
f_lcm(int count, NUMBER **vals)
{
NUMBER *val, *tmp;
val = qqabs(*vals);
while (--count > 0) {
tmp = qlcm(val, *++vals);
qfree(val);
val = tmp;
if (qiszero(val))
break;
}
return val;
}
S_FUNC VALUE
f_hash(int count, VALUE **vals)
{
QCKHASH hash;
VALUE result;
/* initialize VALUE */
result.v_type = V_NUM;
result.v_subtype = V_NOSUBTYPE;
hash = QUICKHASH_BASIS;
while (count-- > 0)
hash = hashvalue(*vals++, hash);
result.v_num = utoq((FULL) hash);
return result;
}
VALUE
sumlistitems(LIST *lp)
{
LISTELEM *ep;
VALUE *vp;
VALUE term;
VALUE tmp;
VALUE sum;
/* initialize VALUEs */
term.v_type = V_NULL;
term.v_subtype = V_NOSUBTYPE;
tmp.v_type = V_NULL;
tmp.v_subtype = V_NOSUBTYPE;
sum.v_type = V_NULL;
sum.v_subtype = V_NOSUBTYPE;
for (ep = lp->l_first; ep; ep = ep->e_next) {
vp = &ep->e_value;
switch(vp->v_type) {
case V_LIST:
term = sumlistitems(vp->v_list);
break;
case V_OBJ:
term = objcall(OBJ_SUM, vp,
NULL_VALUE, NULL_VALUE);
break;
default:
addvalue(&sum, vp, &tmp);
freevalue(&sum);
if (tmp.v_type < 0)
return tmp;
sum = tmp;
continue;
}
addvalue(&sum, &term, &tmp);
freevalue(&sum);
freevalue(&term);
sum = tmp;
if (sum.v_type < 0)
break;
}
return sum;
}
S_FUNC VALUE
f_sum(int count, VALUE **vals)
{
VALUE tmp;
VALUE sum;
VALUE term;
VALUE *vp;
/* initialize VALUEs */
tmp.v_type = V_NULL;
tmp.v_subtype = V_NOSUBTYPE;
sum.v_type = V_NULL;
sum.v_subtype = V_NOSUBTYPE;
term.v_type = V_NULL;
term.v_subtype = V_NOSUBTYPE;
while (count-- > 0) {
vp = *vals++;
switch(vp->v_type) {
case V_LIST:
term = sumlistitems(vp->v_list);
break;
case V_OBJ:
term = objcall(OBJ_SUM, vp,
NULL_VALUE, NULL_VALUE);
break;
default:
addvalue(&sum, vp, &tmp);
freevalue(&sum);
if (tmp.v_type < 0)
return tmp;
sum = tmp;
continue;
}
addvalue(&sum, &term, &tmp);
freevalue(&term);
freevalue(&sum);
sum = tmp;
if (sum.v_type < 0)
break;
}
return sum;
}
S_FUNC VALUE
f_avg(int count, VALUE **vals)
{
VALUE tmp;
VALUE sum;
VALUE div;
long n;
/* initialize VALUEs */
tmp.v_type = V_NULL;
tmp.v_subtype = V_NOSUBTYPE;
sum.v_type = V_NULL;
sum.v_subtype = V_NOSUBTYPE;
div.v_type = V_NULL;
div.v_subtype = V_NOSUBTYPE;
n = 0;
while (count-- > 0) {
if ((*vals)->v_type == V_LIST) {
addlistitems((*vals)->v_list, &sum);
n += countlistitems((*vals++)->v_list);
} else {
addvalue(&sum, *vals++, &tmp);
freevalue(&sum);
sum = tmp;
n++;
}
if (sum.v_type < 0)
return sum;
}
if (n < 2)
return sum;
div.v_num = itoq(n);
div.v_type = V_NUM;
div.v_subtype = V_NOSUBTYPE;
divvalue(&sum, &div, &tmp);
freevalue(&sum);
qfree(div.v_num);
return tmp;
}
S_FUNC VALUE
f_fact(VALUE *vp)
{
VALUE res;
/* initialize VALUE */
res.v_type = V_NUM;
res.v_subtype = V_NOSUBTYPE;
if (vp->v_type == V_OBJ) {
return objcall(OBJ_FACT, vp, NULL_VALUE, NULL_VALUE);
}
if (vp->v_type != V_NUM) {
math_error("Non-real argument for fact()");
not_reached();
}
res.v_num = qfact(vp->v_num);
return res;
}
S_FUNC VALUE
f_hmean(int count, VALUE **vals)
{
VALUE sum, tmp1, tmp2;
long n = 0;
/* initialize VALUEs */
sum.v_type = V_NULL;
sum.v_subtype = V_NOSUBTYPE;
tmp1.v_type = V_NULL;
tmp1.v_subtype = V_NOSUBTYPE;
tmp2.v_type = V_NULL;
tmp2.v_subtype = V_NOSUBTYPE;
while (count-- > 0) {
if ((*vals)->v_type == V_LIST) {
addlistinv((*vals)->v_list, &sum);
n += countlistitems((*vals++)->v_list);
} else {
invertvalue(*vals++, &tmp1);
addvalue(&sum, &tmp1, &tmp2);
freevalue(&tmp1);
freevalue(&sum);
sum = tmp2;
n++;
}
}
if (n == 0)
return sum;
tmp1.v_type = V_NUM;
tmp1.v_subtype = V_NOSUBTYPE;
tmp1.v_num = itoq(n);
divvalue(&tmp1, &sum, &tmp2);
qfree(tmp1.v_num);
freevalue(&sum);
return tmp2;
}
S_FUNC NUMBER *
f_hnrmod(NUMBER *val1, NUMBER *val2, NUMBER *val3, NUMBER *val4)
{
ZVALUE answer; /* v mod h*2^n+r */
NUMBER *res; /* v mod h*2^n+r */
/*
* firewall
*/
if (qisfrac(val1)) {
math_error("1st arg of hnrmod (v) must be an integer");
not_reached();
}
if (qisfrac(val2) || qisneg(val2) || qiszero(val2)) {
math_error("2nd arg of hnrmod (h) must be an integer > 0");
not_reached();
}
if (qisfrac(val3) || qisneg(val3) || qiszero(val3)) {
math_error("3rd arg of hnrmod (n) must be an integer > 0");
not_reached();
}
if (qisfrac(val4) || !zisabsleone(val4->num)) {
math_error("4th arg of hnrmod (r) must be -1, 0 or 1");
not_reached();
}
/*
* perform the val1 mod (val2 * 2^val3 + val4) operation
*/
zhnrmod(val1->num, val2->num, val3->num, val4->num, &answer);
/*
* return the answer
*/
res = qalloc();
res->num = answer;
return res;
}
VALUE
ssqlistitems(LIST *lp)
{
LISTELEM *ep;
VALUE *vp;
VALUE term;
VALUE tmp;
VALUE sum;
/* initialize VALUEs */
term.v_type = V_NULL;
term.v_subtype = V_NOSUBTYPE;
tmp.v_type = V_NULL;
tmp.v_subtype = V_NOSUBTYPE;
sum.v_type = V_NULL;
sum.v_subtype = V_NOSUBTYPE;
for (ep = lp->l_first; ep; ep = ep->e_next) {
vp = &ep->e_value;
if (vp->v_type == V_LIST) {
term = ssqlistitems(vp->v_list);
} else {
squarevalue(vp, &term);
}
addvalue(&sum, &term, &tmp);
freevalue(&sum);
freevalue(&term);
sum = tmp;
if (sum.v_type < 0)
break;
}
return sum;
}
S_FUNC VALUE
f_ssq(int count, VALUE **vals)
{
VALUE tmp;
VALUE sum;
VALUE term;
VALUE *vp;
/* initialize VALUEs */
tmp.v_type = V_NULL;
tmp.v_subtype = V_NOSUBTYPE;
sum.v_type = V_NULL;
sum.v_subtype = V_NOSUBTYPE;
term.v_type = V_NULL;
term.v_subtype = V_NOSUBTYPE;
while (count-- > 0) {
vp = *vals++;
if (vp->v_type == V_LIST) {
term = ssqlistitems(vp->v_list);
} else {
squarevalue(vp, &term);
}
addvalue(&sum, &term, &tmp);
freevalue(&term);
freevalue(&sum);
sum = tmp;
if (sum.v_type < 0)
break;
}
return sum;
}
S_FUNC NUMBER *
f_ismult(NUMBER *val1, NUMBER *val2)
{
return itoq((long) qdivides(val1, val2));
}
S_FUNC NUMBER *
f_meq(NUMBER *val1, NUMBER *val2, NUMBER *val3)
{
NUMBER *tmp, *res;
tmp = qsub(val1, val2);
res = itoq((long) qdivides(tmp, val3));
qfree(tmp);
return res;
}
S_FUNC VALUE
f_exp(int count, VALUE **vals)
{
VALUE result;
NUMBER *eps;
NUMBER *q;
COMPLEX *c;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_EXP_1);
}
eps = vals[1]->v_num;
}
/*
* compute e^x to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
q = qexp(vals[0]->v_num, eps);
if (q == NULL)
return error_value(E_EXP_3);
result.v_num = q;
result.v_type = V_NUM;
break;
case V_COM:
c = c_exp(vals[0]->v_com, eps);
if (c == NULL)
return error_value(E_EXP_3);
result.v_com = c;
result.v_type = V_COM;
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_EXP_2);
}
return result;
}
S_FUNC VALUE
f_ln(int count, VALUE **vals)
{
VALUE result;
COMPLEX ctmp, *c;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_LN_1);
}
err = vals[1]->v_num;
}
/*
* compute natural logarithm to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
if (!qisneg(vals[0]->v_num) &&
!qiszero(vals[0]->v_num)) {
result.v_num = qln(vals[0]->v_num, err);
result.v_type = V_NUM;
return result;
}
ctmp.real = vals[0]->v_num;
ctmp.imag = qlink(&_qzero_);
ctmp.links = 1;
c = c_ln(&ctmp, err);
break;
case V_COM:
c = c_ln(vals[0]->v_com, err);
break;
default:
return error_value(E_LN_2);
}
/* determine if we will return a numeric or complex value */
result.v_type = V_COM;
result.v_com = c;
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
return result;
}
S_FUNC VALUE
f_log(int count, VALUE **vals)
{
VALUE result;
COMPLEX ctmp, *c;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_LOG_1);
}
err = vals[1]->v_num;
}
/*
* compute logarithm base 10 to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
if (!qisneg(vals[0]->v_num) &&
!qiszero(vals[0]->v_num)) {
result.v_num = qlog(vals[0]->v_num, err);
result.v_type = V_NUM;
return result;
}
ctmp.real = vals[0]->v_num;
ctmp.imag = qlink(&_qzero_);
ctmp.links = 1;
c = c_log(&ctmp, err);
break;
case V_COM:
c = c_log(vals[0]->v_com, err);
break;
default:
return error_value(E_LOG_2);
}
if (c == NULL) {
return error_value(E_LOG_3);
}
/* determine if we will return a numeric or complex value */
result.v_type = V_COM;
result.v_com = c;
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
return result;
}
S_FUNC VALUE
f_log2(int count, VALUE **vals)
{
VALUE result;
COMPLEX ctmp, *c;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_LOG2_1);
}
err = vals[1]->v_num;
}
/*
* compute base 2 logarithm to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
if (!qisneg(vals[0]->v_num) &&
!qiszero(vals[0]->v_num)) {
result.v_num = qlog2(vals[0]->v_num, err);
result.v_type = V_NUM;
return result;
}
ctmp.real = vals[0]->v_num;
ctmp.imag = qlink(&_qzero_);
ctmp.links = 1;
c = c_log2(&ctmp, err);
break;
case V_COM:
c = c_log2(vals[0]->v_com, err);
break;
default:
return error_value(E_LOG2_2);
}
if (c == NULL) {
return error_value(E_LOG2_3);
}
/* determine if we will return a numeric or complex value */
result.v_type = V_COM;
result.v_com = c;
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
return result;
}
S_FUNC VALUE
f_logn(int count, VALUE **vals)
{
VALUE result; /* return value */
COMPLEX ctmp; /* intermediate COMPLEX temporary value */
COMPLEX *p_cval; /* pointer to a COMPLEX value */
NUMBER *err; /* epsilon error value */
bool ln_of_x_is_complex = false; /* taking to value of a COMPLEX x */
COMPLEX *ln_x_c; /* ln(x) where ln_of_x_is_complex is true */
NUMBER *ln_x_r; /* ln(x) where ln_of_x_is_complex is false */
bool ln_of_n_is_complex = false; /* taking to value of a COMPLEX base n */
COMPLEX *ln_n_c; /* ln(n) where ln_of_n_is_complex is true */
NUMBER *ln_n_r; /* ln(n) where ln_of_n_is_complex is false */
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 3) {
if (verify_eps(vals[2]) == false) {
return error_value(E_LOGN_1);
}
err = vals[2]->v_num;
}
/*
* special case: x and n are both integer powers of 2 and n log 2 != 0
*
* If this is the case, we return the integer formed by log2(n) / log2(x).
*/
ln_x_r = qalloc();
ln_n_r = qalloc();
if (vals[0]->v_type == V_NUM && qispowerof2(vals[0]->v_num, &ln_x_r) == true) {
if (vals[1]->v_type == V_NUM && qispowerof2(vals[1]->v_num, &ln_n_r) == true) {
if (!qiszero(ln_n_r)) {
result.v_num = qqdiv(ln_x_r, ln_n_r);
if (result.v_com == NULL) {
return error_value(E_LOGN_4);
}
result.v_type = V_NUM;
qfree(ln_x_r);
qfree(ln_n_r);
return result;
} else {
qfree(ln_x_r);
qfree(ln_n_r);
return error_value(E_LOGN_4);
}
}
}
qfree(ln_x_r);
qfree(ln_n_r);
/*
* take the natural log of x (value)
*
* Look for the case where the natural log of x complex is a real.
*/
switch (vals[0]->v_type) {
case V_NUM:
if (qiszero(vals[0]->v_num)) {
return error_value(E_LOGN_3);
}
if (qisneg(vals[0]->v_num)) {
ctmp.real = vals[0]->v_num;
ctmp.imag = qlink(&_qzero_);
ctmp.links = 1;
ln_x_c = c_ln(&ctmp, err);
if (ln_x_c == NULL) {
return error_value(E_LOGN_3);
}
if (cisreal(ln_x_c)) {
ln_x_r = c_to_q(ln_x_c, true);
} else {
ln_of_x_is_complex = true;
}
} else {
ln_x_r = qln(vals[0]->v_num, err);
if (ln_x_r == NULL) {
return error_value(E_LOGN_3);
}
}
break;
case V_COM:
if (ciszero(vals[0]->v_com)) {
return error_value(E_LOGN_3);
}
ln_x_c = c_ln(vals[0]->v_com, err);
if (ln_x_c == NULL) {
return error_value(E_LOGN_3);
}
if (cisreal(ln_x_c)) {
ln_x_r = c_to_q(ln_x_c, true);
} else {
ln_of_x_is_complex = true;
}
break;
default:
return error_value(E_LOGN_2);
}
/*
* take the natural log of n (base)
*
* Look for the case where the natural log of n complex is a real.
* Also report an error if the case where the natural log of n is zero.
*/
switch (vals[1]->v_type) {
case V_NUM:
if (qiszero(vals[1]->v_num)) {
return error_value(E_LOGN_4);
}
if (qisneg(vals[1]->v_num)) {
ctmp.real = vals[1]->v_num;
ctmp.imag = qlink(&_qzero_);
ctmp.links = 1;
ln_n_c = c_ln(&ctmp, err);
if (ln_n_c == NULL) {
return error_value(E_LOGN_4);
}
if (ciszero(ln_n_c)) {
comfree(ln_n_c);
return error_value(E_LOGN_4);
}
if (cisreal(ln_n_c)) {
ln_n_r = c_to_q(ln_n_c, true);
} else {
ln_of_n_is_complex = true;
}
} else {
ln_n_r = qln(vals[1]->v_num, err);
if (ln_n_r == NULL) {
return error_value(E_LOGN_4);
}
if (qiszero(ln_n_r)) {
qfree(ln_n_r);
return error_value(E_LOGN_4);
}
}
break;
case V_COM:
if (ciszero(vals[1]->v_com)) {
return error_value(E_LOGN_4);
}
ln_n_c = c_ln(vals[1]->v_com, err);
if (ln_n_c == NULL) {
return error_value(E_LOGN_4);
}
if (ciszero(ln_n_c)) {
comfree(ln_n_c);
return error_value(E_LOGN_4);
}
if (cisreal(ln_n_c)) {
ln_n_r = c_to_q(ln_n_c, true);
} else {
ln_of_n_is_complex = true;
}
break;
default:
return error_value(E_LOGN_5);
}
/*
* compute ln(x) / ln(n)
*/
if (ln_of_x_is_complex == true) {
if (ln_of_n_is_complex == true) {
/*
* case: ln(x) is COMPLEX, ln(n) is COMPLEX
*/
p_cval = c_div(ln_x_c, ln_n_c);
if (p_cval == NULL) {
return error_value(E_LOGN_3);
}
/* check if division is COMPLEX or NUMBER */
if (cisreal(p_cval)) {
/* ln(x) / ln(n) was NUMBER, not COMPLEX */
result.v_num = c_to_q(p_cval, true);
result.v_type = V_NUM;
} else {
/* ln(x) / ln(n) is COMPLEX */
result.v_type = V_COM;
result.v_com = p_cval;
}
} else {
/*
* case: ln(x) is COMPLEX, ln(n) is NUMBER
*/
p_cval = c_divq(ln_x_c, ln_n_r);
if (p_cval == NULL) {
return error_value(E_LOGN_3);
}
/* check if division is COMPLEX or NUMBER */
if (cisreal(p_cval)) {
/* ln(x) / ln(n) was NUMBER, not COMPLEX */
result.v_num = c_to_q(p_cval, true);
result.v_type = V_NUM;
} else {
/* ln(x) / ln(n) is COMPLEX */
result.v_type = V_COM;
result.v_com = p_cval;
}
}
} else {
if (ln_of_n_is_complex == true) {
/*
* case: ln(x) is NUMBER, ln(n) is COMPLEX
*/
/* convert ln_x_r into COMPLEX so we can divide */
ctmp.real = ln_x_r;
ctmp.imag = qlink(&_qzero_);
ctmp.links = 1;
p_cval = c_div(&ctmp, ln_n_c);
if (result.v_com == NULL) {
return error_value(E_LOGN_3);
}
/* check if division is COMPLEX or NUMBER */
if (cisreal(p_cval)) {
/* ln(x) / ln(n) was NUMBER, not COMPLEX */
result.v_num = c_to_q(p_cval, true);
result.v_type = V_NUM;
} else {
/* ln(x) / ln(n) is COMPLEX */
result.v_type = V_COM;
result.v_com = p_cval;
}
} else {
/*
* case: ln(x) is NUMBER, ln(n) is NUMBER
*/
result.v_num = qqdiv(ln_x_r, ln_n_r);
if (result.v_com == NULL) {
return error_value(E_LOGN_3);
}
/* ln(x) / ln(n) is NUMBER */
result.v_type = V_NUM;
}
}
/* return the resulting logarithm */
return result;
}
S_FUNC VALUE
f_cos(int count, VALUE **vals)
{
VALUE result;
COMPLEX *c;
NUMBER *eps;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_COS_1);
}
eps = vals[1]->v_num;
}
/*
* compute cosinr to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qcos(vals[0]->v_num, eps);
result.v_type = V_NUM;
break;
case V_COM:
c = c_cos(vals[0]->v_com, eps);
if (c == NULL)
return error_value(E_COS_3);
result.v_com = c;
result.v_type = V_COM;
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_COS_2);
}
return result;
}
/*
* f_d2r - convert degrees to radians
*/
S_FUNC VALUE
f_d2r(int count, VALUE **vals)
{
VALUE result;
NUMBER *eps;
NUMBER *pidiv180;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_D2R_1);
}
eps = vals[1]->v_num;
}
/*
* compute argument*(pi/180) to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
pidiv180 = qpidiv180(eps);
result.v_num = qmul(vals[0]->v_num, pidiv180);
result.v_type = V_NUM;
qfree(pidiv180);
break;
case V_COM:
pidiv180 = qpidiv180(eps);
result.v_com = c_mulq(vals[0]->v_com, pidiv180);
result.v_type = V_COM;
qfree(pidiv180);
break;
default:
return error_value(E_D2R_2);
}
return result;
}
/*
* f_r2d - convert radians to degrees
*/
S_FUNC VALUE
f_r2d(int count, VALUE **vals)
{
VALUE result;
NUMBER *eps;
NUMBER *pidiv180;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_R2D_1);
}
eps = vals[1]->v_num;
}
/*
* compute argument/(pi/180) to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
pidiv180 = qpidiv180(eps);
result.v_num = qqdiv(vals[0]->v_num, pidiv180);
result.v_type = V_NUM;
qfree(pidiv180);
break;
case V_COM:
pidiv180 = qpidiv180(eps);
result.v_com = c_divq(vals[0]->v_com, pidiv180);
result.v_type = V_COM;
qfree(pidiv180);
break;
default:
return error_value(E_R2D_2);
}
return result;
}
/*
* f_d2r - convert gradians to radians
*/
S_FUNC VALUE
f_g2r(int count, VALUE **vals)
{
VALUE result;
NUMBER *eps;
NUMBER *pidiv200;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_G2R_1);
}
eps = vals[1]->v_num;
}
/*
* compute argument*(pi/200) to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
pidiv200 = qpidiv200(eps);
result.v_num = qmul(vals[0]->v_num, pidiv200);
result.v_type = V_NUM;
qfree(pidiv200);
break;
case V_COM:
pidiv200 = qpidiv200(eps);
result.v_com = c_mulq(vals[0]->v_com, pidiv200);
result.v_type = V_COM;
qfree(pidiv200);
break;
default:
return error_value(E_G2R_2);
}
return result;
}
/*
* f_r2g - convert radians to gradians
*/
S_FUNC VALUE
f_r2g(int count, VALUE **vals)
{
VALUE result;
NUMBER *eps;
NUMBER *pidiv200;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_R2G_1);
}
eps = vals[1]->v_num;
}
/*
* compute argument/(pi/200) to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
pidiv200 = qpidiv200(eps);
result.v_num = qqdiv(vals[0]->v_num, pidiv200);
result.v_type = V_NUM;
qfree(pidiv200);
break;
case V_COM:
pidiv200 = qpidiv200(eps);
result.v_com = c_divq(vals[0]->v_com, pidiv200);
result.v_type = V_COM;
qfree(pidiv200);
break;
default:
return error_value(E_R2G_2);
}
return result;
}
/*
* f_d2g - convert degrees to gradians
*
* NOTE: The epsilon (vals[1]->v_num) argument is ignored.
*/
/*ARGSUSED*/
S_FUNC VALUE
f_d2g(int UNUSED(count), VALUE **vals)
{
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/* NOTE: the epsilon (vals[1]->v_num) argument is ignored */
/* calculate argument * (10/9) */
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qmul(vals[0]->v_num, &_qtendivnine_);
result.v_type = V_NUM;
break;
case V_COM:
result.v_com = c_mulq(vals[0]->v_com, &_qtendivnine_);
result.v_type = V_COM;
break;
default:
return error_value(E_D2G_1);
}
return result;
}
/*
* f_g2d - convert gradians to degrees
*
* NOTE: The epsilon (vals[1]->v_num) argument is ignored.
*/
/*ARGSUSED*/
S_FUNC VALUE
f_g2d(int UNUSED(count), VALUE **vals)
{
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/* NOTE: the epsilon (vals[1]->v_num) argument is ignored */
/* calculate argument * (9/10) */
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qmul(vals[0]->v_num, &_qninedivten_);
result.v_type = V_NUM;
break;
case V_COM:
result.v_com = c_mulq(vals[0]->v_com, &_qninedivten_);
result.v_type = V_COM;
break;
default:
return error_value(E_G2D_1);
}
return result;
}
S_FUNC VALUE
f_sin(int count, VALUE **vals)
{
VALUE result;
COMPLEX *c;
NUMBER *eps;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_SIN_1);
}
eps = vals[1]->v_num;
}
/*
* compute sine to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qsin(vals[0]->v_num, eps);
result.v_type = V_NUM;
break;
case V_COM:
c = c_sin(vals[0]->v_com, eps);
if (c == NULL) {
return error_value(E_SIN_3);
}
result.v_com = c;
result.v_type = V_COM;
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_SIN_2);
}
return result;
}
S_FUNC VALUE
f_tan(int count, VALUE **vals)
{
VALUE result;
COMPLEX *c;
NUMBER *err;
/* initialize VALUEs */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use err VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_TAN_1);
}
err = vals[1]->v_num;
}
/*
* compute tangent to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qtan(vals[0]->v_num, err);
result.v_type = V_NUM;
break;
case V_COM:
c = c_tan(vals[0]->v_com, err);
if (c == NULL) {
return error_value(E_TAN_5);
}
result.v_com = c;
result.v_type = V_COM;
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_TAN_2);
}
return result;
}
S_FUNC VALUE
f_cot(int count, VALUE **vals)
{
VALUE result;
COMPLEX *c;
NUMBER *err;
/* initialize VALUEs */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use err VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_COT_1);
}
err = vals[1]->v_num;
}
/*
* compute cotangent to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
if (qiszero(vals[0]->v_num)) {
return error_value(E_COT_5);
}
result.v_num = qcot(vals[0]->v_num, err);
result.v_type = V_NUM;
break;
case V_COM:
if (ciszero(vals[0]->v_com)) {
return error_value(E_COT_5);
}
c = c_cot(vals[0]->v_com, err);
if (c == NULL) {
return error_value(E_COT_6);
}
result.v_com = c;
result.v_type = V_COM;
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_COT_2);
}
return result;
}
S_FUNC VALUE
f_sec(int count, VALUE **vals)
{
VALUE result;
COMPLEX *c;
NUMBER *err;
/* initialize VALUEs */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use err VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_SEC_1);
}
err = vals[1]->v_num;
}
/*
* compute secant to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qsec(vals[0]->v_num, err);
result.v_type = V_NUM;
break;
case V_COM:
c = c_sec(vals[0]->v_com, err);
if (c == NULL) {
return error_value(E_SEC_5);
}
result.v_com = c;
result.v_type = V_COM;
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_SEC_2);
}
return result;
}
S_FUNC VALUE
f_csc(int count, VALUE **vals)
{
VALUE result;
COMPLEX *c;
NUMBER *err;
/* initialize VALUEs */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use err VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_CSC_1);
}
err = vals[1]->v_num;
}
/*
* compute cosecant to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
if (qiszero(vals[0]->v_num)) {
return error_value(E_CSC_5);
}
result.v_num = qcsc(vals[0]->v_num, err);
result.v_type = V_NUM;
break;
case V_COM:
if (ciszero(vals[0]->v_com)) {
return error_value(E_CSC_5);
}
c = c_csc(vals[0]->v_com, err);
if (c == NULL) {
return error_value(E_CSC_6);
}
result.v_com = c;
result.v_type = V_COM;
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_CSC_2);
}
return result;
}
S_FUNC VALUE
f_sinh(int count, VALUE **vals)
{
VALUE result;
NUMBER *eps;
NUMBER *q;
COMPLEX *c;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_SINH_1);
}
eps = vals[1]->v_num;
}
/*
* compute hyperbolic sine to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
q = qsinh(vals[0]->v_num, eps);
if (q == NULL)
return error_value(E_SINH_3);
result.v_num = q;
result.v_type = V_NUM;
break;
case V_COM:
c = c_sinh(vals[0]->v_com, eps);
if (c == NULL)
return error_value(E_SINH_3);
result.v_com = c;
result.v_type = V_COM;
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_SINH_2);
}
return result;
}
S_FUNC VALUE
f_cosh(int count, VALUE **vals)
{
VALUE result;
NUMBER *eps;
NUMBER *q;
COMPLEX *c;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_COSH_1);
}
eps = vals[1]->v_num;
}
/*
* compute hyperbolic cosine to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
q = qcosh(vals[0]->v_num, eps);
if (q == NULL)
return error_value(E_COSH_3);
result.v_num = q;
result.v_type = V_NUM;
break;
case V_COM:
c = c_cosh(vals[0]->v_com, eps);
if (c == NULL)
return error_value(E_COSH_3);
result.v_com = c;
result.v_type = V_COM;
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_COSH_2);
}
return result;
}
S_FUNC VALUE
f_tanh(int count, VALUE **vals)
{
VALUE result;
VALUE tmp1, tmp2;
NUMBER *err;
/* initialize VALUEs */
result.v_subtype = V_NOSUBTYPE;
tmp1.v_subtype = V_NOSUBTYPE;
tmp2.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_TANH_1);
}
err = vals[1]->v_num;
}
/*
* compute hyperbolic tangent to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qtanh(vals[0]->v_num, err);
result.v_type = V_NUM;
break;
case V_COM:
tmp1.v_type = V_COM;
tmp1.v_com = c_sinh(vals[0]->v_com, err);
if (tmp1.v_com == NULL) {
return error_value(E_TANH_3);
}
tmp2.v_type = V_COM;
tmp2.v_com = c_cosh(vals[0]->v_com, err);
if (tmp2.v_com == NULL) {
comfree(tmp1.v_com);
return error_value(E_TANH_4);
}
divvalue(&tmp1, &tmp2, &result);
comfree(tmp1.v_com);
comfree(tmp2.v_com);
break;
default:
return error_value(E_TANH_2);
}
return result;
}
S_FUNC VALUE
f_coth(int count, VALUE **vals)
{
VALUE result;
VALUE tmp1, tmp2;
NUMBER *err;
/* initialize VALUEs */
result.v_subtype = V_NOSUBTYPE;
tmp1.v_subtype = V_NOSUBTYPE;
tmp2.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_COTH_1);
}
err = vals[1]->v_num;
}
/*
* compute hyperbolic cotangent to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
if (qiszero(vals[0]->v_num))
return error_value(E_DIVBYZERO);
result.v_num = qcoth(vals[0]->v_num, err);
result.v_type = V_NUM;
break;
case V_COM:
tmp1.v_type = V_COM;
tmp1.v_com = c_cosh(vals[0]->v_com, err);
if (tmp1.v_com == NULL) {
return error_value(E_COTH_3);
}
tmp2.v_type = V_COM;
tmp2.v_com = c_sinh(vals[0]->v_com, err);
if (tmp2.v_com == NULL) {
comfree(tmp1.v_com);
return error_value(E_COTH_4);
}
divvalue(&tmp1, &tmp2, &result);
comfree(tmp1.v_com);
comfree(tmp2.v_com);
break;
default:
return error_value(E_COTH_2);
}
return result;
}
S_FUNC VALUE
f_sech(int count, VALUE **vals)
{
VALUE result;
VALUE tmp;
NUMBER *err;
/* initialize VALUEs */
result.v_subtype = V_NOSUBTYPE;
tmp.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_SECH_1);
}
err = vals[1]->v_num;
}
/*
* compute hyperbolic secant to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qsech(vals[0]->v_num, err);
result.v_type = V_NUM;
break;
case V_COM:
tmp.v_type = V_COM;
tmp.v_com = c_cosh(vals[0]->v_com, err);
if (tmp.v_com == NULL) {
return error_value(E_SECH_3);
}
invertvalue(&tmp, &result);
comfree(tmp.v_com);
break;
default:
return error_value(E_SECH_2);
}
return result;
}
S_FUNC VALUE
f_csch(int count, VALUE **vals)
{
VALUE result;
VALUE tmp;
NUMBER *err;
/* initialize VALUEs */
result.v_subtype = V_NOSUBTYPE;
tmp.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_CSCH_1);
}
err = vals[1]->v_num;
}
/*
* compute hyperbolic cosecant to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
if (qiszero(vals[0]->v_num))
return error_value(E_DIVBYZERO);
result.v_num = qcsch(vals[0]->v_num, err);
result.v_type = V_NUM;
break;
case V_COM:
tmp.v_type = V_COM;
tmp.v_com = c_sinh(vals[0]->v_com, err);
if (tmp.v_com == NULL) {
return error_value(E_CSCH_3);
}
invertvalue(&tmp, &result);
comfree(tmp.v_com);
break;
default:
return error_value(E_CSCH_2);
}
return result;
}
S_FUNC VALUE
f_atan(int count, VALUE **vals)
{
VALUE result;
COMPLEX *tmp;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_ATAN_1);
}
err = vals[1]->v_num;
}
/*
* compute inverse tangent to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qatan(vals[0]->v_num, err);
result.v_type = V_NUM;
break;
case V_COM:
tmp = c_atan(vals[0]->v_com, err);
if (tmp == NULL)
return error_value(E_ATAN_3);
result.v_type = V_COM;
result.v_com = tmp;
if (cisreal(tmp)) {
result.v_num = c_to_q(tmp, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_ATAN_2);
}
return result;
}
S_FUNC VALUE
f_acot(int count, VALUE **vals)
{
VALUE result;
COMPLEX *tmp;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_ACOT_1);
}
err = vals[1]->v_num;
}
/*
* compute inverse cotangent to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qacot(vals[0]->v_num, err);
result.v_type = V_NUM;
break;
case V_COM:
tmp = c_acot(vals[0]->v_com, err);
if (tmp == NULL)
return error_value(E_ACOT_3);
result.v_type = V_COM;
result.v_com = tmp;
if (cisreal(tmp)) {
result.v_num = c_to_q(tmp, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_ACOT_2);
}
return result;
}
S_FUNC VALUE
f_asin(int count, VALUE **vals)
{
VALUE result;
COMPLEX *tmp;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_ASIN_1);
}
err = vals[1]->v_num;
}
/*
* compute inverse sine to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qasin(vals[0]->v_num, err);
result.v_type = V_NUM;
if (result.v_num == NULL) {
tmp = comalloc();
qfree(tmp->real);
tmp->real = qlink(vals[0]->v_num);
result.v_type = V_COM;
result.v_com = c_asin(tmp, err);
comfree(tmp);
}
break;
case V_COM:
result.v_com = c_asin(vals[0]->v_com, err);
result.v_type = V_COM;
break;
default:
return error_value(E_ASIN_2);
}
if (result.v_com == NULL) {
return error_value(E_ASIN_3);
}
if (result.v_type == V_COM && cisreal(result.v_com)) {
result.v_num = c_to_q(result.v_com, true);
result.v_type = V_NUM;
}
return result;
}
S_FUNC VALUE
f_acos(int count, VALUE **vals)
{
VALUE result;
COMPLEX *tmp;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_ACOS_1);
}
err = vals[1]->v_num;
}
/*
* compute inverse cosine to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qacos(vals[0]->v_num, err);
result.v_type = V_NUM;
if (result.v_num == NULL) {
tmp = comalloc();
qfree(tmp->real);
tmp->real = qlink(vals[0]->v_num);
result.v_type = V_COM;
result.v_com = c_acos(tmp, err);
comfree(tmp);
}
break;
case V_COM:
result.v_com = c_acos(vals[0]->v_com, err);
result.v_type = V_COM;
break;
default:
return error_value(E_ACOS_2);
}
if (result.v_com == NULL) {
return error_value(E_ACOS_3);
}
if (result.v_type == V_COM && cisreal(result.v_com)) {
result.v_num = c_to_q(result.v_com, true);
result.v_type = V_NUM;
}
return result;
}
S_FUNC VALUE
f_asec(int count, VALUE **vals)
{
VALUE result;
COMPLEX *tmp;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_ASEC_1);
}
err = vals[1]->v_num;
}
/*
* compute inverse secant to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
if (qiszero(vals[0]->v_num))
return error_value(E_ASEC_3);
result.v_num = qasec(vals[0]->v_num, err);
result.v_type = V_NUM;
if (result.v_num == NULL) {
tmp = comalloc();
qfree(tmp->real);
tmp->real = qlink(vals[0]->v_num);
result.v_com = c_asec(tmp, err);
result.v_type = V_COM;
comfree(tmp);
}
break;
case V_COM:
result.v_com = c_asec(vals[0]->v_com, err);
result.v_type = V_COM;
break;
default:
return error_value(E_ASEC_2);
}
if (result.v_com == NULL) {
return error_value(E_ASEC_3);
}
if (result.v_type == V_COM) {
if (cisreal(result.v_com)) {
result.v_num = c_to_q(result.v_com, true);
result.v_type = V_NUM;
}
}
return result;
}
S_FUNC VALUE
f_acsc(int count, VALUE **vals)
{
VALUE result;
COMPLEX *tmp;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_ACSC_1);
}
err = vals[1]->v_num;
}
/*
* compute inverse cosecant to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
if (qiszero(vals[0]->v_num))
return error_value(E_ACSC_3);
result.v_num = qacsc(vals[0]->v_num, err);
result.v_type = V_NUM;
if (result.v_num == NULL) {
tmp = comalloc();
qfree(tmp->real);
tmp->real = qlink(vals[0]->v_num);
result.v_com = c_acsc(tmp, err);
result.v_type = V_COM;
comfree(tmp);
}
break;
case V_COM:
result.v_com = c_acsc(vals[0]->v_com, err);
result.v_type = V_COM;
break;
default:
return error_value(E_ACSC_2);
}
if (result.v_com == NULL) {
return error_value(E_ACSC_3);
}
if (result.v_type == V_COM) {
if (cisreal(result.v_com)) {
result.v_num = c_to_q(result.v_com, true);
result.v_type = V_NUM;
}
}
return result;
}
S_FUNC VALUE
f_asinh(int count, VALUE **vals)
{
VALUE result;
COMPLEX *tmp;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_ASINH_1);
}
err = vals[1]->v_num;
}
/*
* compute inverse hyperbolic sine to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qasinh(vals[0]->v_num, err);
result.v_type = V_NUM;
break;
case V_COM:
tmp = c_asinh(vals[0]->v_com, err);
if (tmp == NULL) {
return error_value(E_ASINH_3);
}
result.v_type = V_COM;
result.v_com = tmp;
if (cisreal(tmp)) {
result.v_num = c_to_q(tmp, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_ASINH_2);
}
return result;
}
S_FUNC VALUE
f_acosh(int count, VALUE **vals)
{
VALUE result;
COMPLEX *tmp;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_ACOSH_1);
}
err = vals[1]->v_num;
}
/*
* compute inverse hyperbolic cosine to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qacosh(vals[0]->v_num, err);
result.v_type = V_NUM;
if (result.v_num == NULL) {
tmp = comalloc();
qfree(tmp->real);
tmp->real = qlink(vals[0]->v_num);
result.v_com = c_acosh(tmp, err);
result.v_type = V_COM;
comfree(tmp);
}
break;
case V_COM:
result.v_com = c_acosh(vals[0]->v_com, err);
result.v_type = V_COM;
break;
default:
return error_value(E_ACOSH_2);
}
if (result.v_com == NULL) {
return error_value(E_ACOSH_3);
}
if (result.v_type == V_COM && cisreal(result.v_com)) {
result.v_num = c_to_q(result.v_com, true);
result.v_type = V_NUM;
}
return result;
}
S_FUNC VALUE
f_atanh(int count, VALUE **vals)
{
VALUE result;
COMPLEX *tmp;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_ATANH_1);
}
err = vals[1]->v_num;
}
/*
* compute inverse hyperbolic tangent to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qatanh(vals[0]->v_num, err);
result.v_type = V_NUM;
if (result.v_num == NULL) {
tmp = comalloc();
qfree(tmp->real);
tmp->real = qlink(vals[0]->v_num);
result.v_com = c_atanh(tmp, err);
result.v_type = V_COM;
comfree(tmp);
}
break;
case V_COM:
result.v_com = c_atanh(vals[0]->v_com, err);
result.v_type = V_COM;
break;
default:
return error_value(E_ATANH_2);
}
if (result.v_com == NULL) {
return error_value(E_ATANH_3);
}
if (result.v_type == V_COM) {
if (cisreal(result.v_com)) {
result.v_num = c_to_q(result.v_com, true);
result.v_type = V_NUM;
}
}
return result;
}
S_FUNC VALUE
f_acoth(int count, VALUE **vals)
{
VALUE result;
COMPLEX *tmp;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_ACOTH_1);
}
err = vals[1]->v_num;
}
/*
* compute inverse hyperbolic cotangent to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qacoth(vals[0]->v_num, err);
result.v_type = V_NUM;
if (result.v_num == NULL) {
tmp = comalloc();
qfree(tmp->real);
tmp->real = qlink(vals[0]->v_num);
result.v_com = c_acoth(tmp, err);
result.v_type = V_COM;
comfree(tmp);
}
break;
case V_COM:
result.v_com = c_acoth(vals[0]->v_com, err);
result.v_type = V_COM;
break;
default:
return error_value(E_ACOTH_2);
}
if (result.v_com == NULL) {
return error_value(E_ACOTH_3);
}
if (result.v_type == V_COM) {
if (cisreal(result.v_com)) {
result.v_num = c_to_q(result.v_com, true);
result.v_type = V_NUM;
}
}
return result;
}
S_FUNC VALUE
f_asech(int count, VALUE **vals)
{
VALUE result;
COMPLEX *tmp;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_SECH_1);
}
err = vals[1]->v_num;
}
/*
* compute inverse hyperbolic secant to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
if (qiszero(vals[0]->v_num))
return error_value(E_ASECH_3);
result.v_num = qasech(vals[0]->v_num, err);
result.v_type = V_NUM;
if (result.v_num == NULL) {
tmp = comalloc();
qfree(tmp->real);
tmp->real = qlink(vals[0]->v_num);
result.v_com = c_asech(tmp, err);
result.v_type = V_COM;
comfree(tmp);
}
break;
case V_COM:
result.v_com = c_asech(vals[0]->v_com, err);
result.v_type = V_COM;
break;
default:
return error_value(E_ASECH_2);
}
if (result.v_com == NULL) {
return error_value(E_ASECH_3);
}
if (result.v_type == V_COM) {
if (cisreal(result.v_com)) {
result.v_num = c_to_q(result.v_com, true);
result.v_type = V_NUM;
}
}
return result;
}
S_FUNC VALUE
f_acsch(int count, VALUE **vals)
{
VALUE result;
COMPLEX *tmp;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_ACSCH_1);
}
err = vals[1]->v_num;
}
/*
* compute inverse hyperbolic cosecant to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
if (qiszero(vals[0]->v_num))
return error_value(E_ACSCH_3);
result.v_num = qacsch(vals[0]->v_num, err);
result.v_type = V_NUM;
if (result.v_num == NULL) {
tmp = comalloc();
qfree(tmp->real);
tmp->real = qlink(vals[0]->v_num);
result.v_com = c_acsch(tmp, err);
result.v_type = V_COM;
comfree(tmp);
}
break;
case V_COM:
result.v_com = c_acsch(vals[0]->v_com, err);
result.v_type = V_COM;
break;
default:
return error_value(E_ACSCH_2);
}
if (result.v_com == NULL) {
return error_value(E_ACSCH_3);
}
if (result.v_type == V_COM) {
if (cisreal(result.v_com)) {
result.v_num = c_to_q(result.v_com, true);
result.v_type = V_NUM;
}
}
return result;
}
S_FUNC VALUE
f_gd(int count, VALUE **vals)
{
VALUE result;
NUMBER *eps;
COMPLEX *tmp;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_GD_1);
}
eps = vals[1]->v_num;
}
/*
* compute Gudermannian function to a given error tolerance
*/
result.v_type = V_COM;
switch (vals[0]->v_type) {
case V_NUM:
if (qiszero(vals[0]->v_num)) {
result.v_type = V_NUM;
result.v_num = qlink(&_qzero_);
return result;
}
tmp = comalloc();
qfree(tmp->real);
tmp->real = qlink(vals[0]->v_num);
result.v_com = c_gd(tmp, eps);
comfree(tmp);
break;
case V_COM:
result.v_com = c_gd(vals[0]->v_com, eps);
break;
default:
return error_value(E_GD_2);
}
if (result.v_com == NULL)
return error_value(E_GD_3);
if (cisreal(result.v_com)) {
result.v_num = c_to_q(result.v_com, true);
result.v_type = V_NUM;
}
return result;
}
S_FUNC VALUE
f_agd(int count, VALUE **vals)
{
VALUE result;
NUMBER *eps;
COMPLEX *tmp;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given as a NUMBER and != 0.
*/
eps = conf->epsilon;
if (count == 2) {
if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) {
return error_value(E_AGD_1);
}
eps = vals[1]->v_num;
}
/*
* compute inverse Gudermannian function to a given error tolerance
*/
result.v_type = V_COM;
switch (vals[0]->v_type) {
case V_NUM:
if (qiszero(vals[0]->v_num)) {
result.v_type = V_NUM;
result.v_num = qlink(&_qzero_);
return result;
}
tmp = comalloc();
qfree(tmp->real);
tmp->real = qlink(vals[0]->v_num);
result.v_com = c_agd(tmp, eps);
comfree(tmp);
break;
case V_COM:
result.v_com = c_agd(vals[0]->v_com, eps);
break;
default:
return error_value(E_AGD_2);
}
if (result.v_com == NULL)
return error_value(E_AGD_3);
if (cisreal(result.v_com)) {
result.v_num = c_to_q(result.v_com, true);
result.v_type = V_NUM;
}
return result;
}
S_FUNC VALUE
f_comb(VALUE *v1, VALUE *v2)
{
long n;
VALUE result;
VALUE tmp1, tmp2, div;
if (v2->v_type != V_NUM || qisfrac(v2->v_num))
return error_value(E_COMB_1);
result.v_subtype = V_NOSUBTYPE;
result.v_type = V_NUM;
if (qisneg(v2->v_num)) {
result.v_num = qlink(&_qzero_);
return result;
}
if (qiszero(v2->v_num)) {
result.v_num = qlink(&_qone_);
return result;
}
if (qisone(v2->v_num)) {
copyvalue(v1, &result);
return result;
}
if (v1->v_type == V_NUM) {
result.v_num = qcomb(v1->v_num, v2->v_num);
if (result.v_num == NULL)
return error_value(E_COMB_2);
return result;
}
if (zge24b(v2->v_num->num))
return error_value(E_COMB_2);
n = qtoi(v2->v_num);
copyvalue(v1, &result);
decvalue(v1, &tmp1);
div.v_type = V_NUM;
div.v_subtype = V_NOSUBTYPE;
div.v_num = qlink(&_qtwo_);
n--;
for (;;) {
mulvalue(&result, &tmp1, &tmp2);
freevalue(&result);
divvalue(&tmp2, &div, &result);
freevalue(&tmp2);
if (--n == 0 || !testvalue(&result) || result.v_type < 0) {
freevalue(&tmp1);
freevalue(&div);
return result;
}
decvalue(&tmp1, &tmp2);
freevalue(&tmp1);
tmp1 = tmp2;
incvalue(&div, &tmp2);
freevalue(&div);
div = tmp2;
}
}
S_FUNC VALUE
f_bern(VALUE *vp)
{
VALUE res;
if (vp->v_type != V_NUM || qisfrac(vp->v_num))
return error_value(E_BERN);
res.v_subtype = V_NOSUBTYPE;
res.v_type = V_NUM;
res.v_num = qbern(vp->v_num->num);
if (res.v_num == NULL)
return error_value(E_BERN);
return res;
}
S_FUNC VALUE
f_freebern(void)
{
VALUE res;
qfreebern();
res.v_type = V_NULL;
res.v_subtype = V_NOSUBTYPE;
return res;
}
S_FUNC VALUE
f_euler(VALUE *vp)
{
VALUE res;
if (vp->v_type!=V_NUM || qisfrac(vp->v_num))
return error_value(E_EULER);
res.v_subtype = V_NOSUBTYPE;
res.v_type = V_NUM;
res.v_num = qeuler(vp->v_num->num);
if (res.v_num == NULL)
return error_value(E_EULER);
return res;
}
S_FUNC VALUE
f_freeeuler(void)
{
VALUE res;
qfreeeuler();
res.v_type = V_NULL;
res.v_subtype = V_NOSUBTYPE;
return res;
}
S_FUNC VALUE
f_catalan(VALUE *vp)
{
VALUE res;
if (vp->v_type!=V_NUM || qisfrac(vp->v_num) || zge31b(vp->v_num->num))
return error_value(E_CTLN);
res.v_type = V_NUM;
res.v_subtype = V_NOSUBTYPE;
res.v_num = qcatalan(vp->v_num);
if (res.v_num == NULL)
return error_value(E_CTLN);
return res;
}
S_FUNC VALUE
f_arg(int count, VALUE **vals)
{
VALUE result;
COMPLEX *c;
NUMBER *err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given as a NUMBER and != 0.
*/
err = conf->epsilon;
if (count == 2) {
if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) {
return error_value(E_ARG_1);
}
err = vals[1]->v_num;
}
/*
* compute argument (the angle or phase) of a complex number to a given error tolerance
*/
result.v_type = V_NUM;
switch (vals[0]->v_type) {
case V_NUM:
if (qisneg(vals[0]->v_num))
result.v_num = qpi(err);
else
result.v_num = qlink(&_qzero_);
break;
case V_COM:
c = vals[0]->v_com;
if (ciszero(c))
result.v_num = qlink(&_qzero_);
else
result.v_num = qatan2(c->imag, c->real, err);
break;
default:
return error_value(E_ARG_2);
}
return result;
}
S_FUNC NUMBER *
f_legtoleg(NUMBER *val1, NUMBER *val2)
{
/* qlegtoleg() performs the val2 != 0 check */
return qlegtoleg(val1, val2, false);
}
S_FUNC NUMBER *
f_trunc(int count, NUMBER **vals)
{
NUMBER *val;
val = qlink(&_qzero_);
if (count == 2)
val = vals[1];
return qtrunc(*vals, val);
}
S_FUNC VALUE
f_bround(int count, VALUE **vals)
{
VALUE tmp1, tmp2, res;
/* initialize VALUEs */
res.v_subtype = V_NOSUBTYPE;
tmp1.v_subtype = V_NOSUBTYPE;
tmp2.v_subtype = V_NOSUBTYPE;
if (count > 2)
tmp2 = *vals[2];
else
tmp2.v_type = V_NULL;
if (count > 1)
tmp1 = *vals[1];
else
tmp1.v_type = V_NULL;
broundvalue(vals[0], &tmp1, &tmp2, &res);
return res;
}
S_FUNC VALUE
f_appr(int count, VALUE **vals)
{
VALUE tmp1, tmp2, res;
/* initialize VALUEs */
res.v_subtype = V_NOSUBTYPE;
tmp1.v_subtype = V_NOSUBTYPE;
tmp2.v_subtype = V_NOSUBTYPE;
if (count > 2)
copyvalue(vals[2], &tmp2);
else
tmp2.v_type = V_NULL;
if (count > 1)
copyvalue(vals[1], &tmp1);
else
tmp1.v_type = V_NULL;
apprvalue(vals[0], &tmp1, &tmp2, &res);
freevalue(&tmp1);
freevalue(&tmp2);
return res;
}
S_FUNC VALUE
f_round(int count, VALUE **vals)
{
VALUE tmp1, tmp2, res;
/* initialize VALUEs */
res.v_subtype = V_NOSUBTYPE;
tmp1.v_subtype = V_NOSUBTYPE;
tmp2.v_subtype = V_NOSUBTYPE;
if (count > 2)
tmp2 = *vals[2];
else
tmp2.v_type = V_NULL;
if (count > 1)
tmp1 = *vals[1];
else
tmp1.v_type = V_NULL;
roundvalue(vals[0], &tmp1, &tmp2, &res);
return res;
}
S_FUNC NUMBER *
f_btrunc(int count, NUMBER **vals)
{
NUMBER *val;
val = qlink(&_qzero_);
if (count == 2)
val = vals[1];
return qbtrunc(*vals, val);
}
S_FUNC VALUE
f_quo(int count, VALUE **vals)
{
VALUE tmp, res;
/* initialize VALUEs */
res.v_subtype = V_NOSUBTYPE;
tmp.v_subtype = V_NOSUBTYPE;
if (count > 2)
tmp = *vals[2];
else
tmp.v_type = V_NULL;
quovalue(vals[0], vals[1], &tmp, &res);
return res;
}
S_FUNC VALUE
f_mod(int count, VALUE **vals)
{
VALUE tmp, res;
/* initialize VALUEs */
res.v_subtype = V_NOSUBTYPE;
tmp.v_subtype = V_NOSUBTYPE;
if (count > 2)
tmp = *vals[2];
else
tmp.v_type = V_NULL;
modvalue(vals[0], vals[1], &tmp, &res);
return res;
}
S_FUNC VALUE
f_quomod(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3, *v4, *v5;
VALUE result;
long rnd;
bool res;
short s3, s4; /* to preserve subtypes of v3, v4 */
v1 = vals[0];
v2 = vals[1];
v3 = vals[2];
v4 = vals[3];
if (v3->v_type != V_ADDR || v4->v_type != V_ADDR ||
v3->v_addr == v4->v_addr)
return error_value(E_QUOMOD_1);
if (count == 5) {
v5 = vals[4];
if (v5->v_type == V_ADDR)
v5 = v5->v_addr;
if (v5->v_type != V_NUM || qisfrac(v5->v_num) ||
qisneg(v5->v_num) || zge31b(v5->v_num->num))
return error_value(E_QUOMOD_2);
rnd = qtoi(v5->v_num);
} else
rnd = conf->quomod;
if (v1->v_type == V_ADDR)
v1 = v1->v_addr;
if (v2->v_type == V_ADDR)
v2 = v2->v_addr;
v3 = v3->v_addr;
v4 = v4->v_addr;
if (v1->v_type != V_NUM || v2->v_type != V_NUM ||
(v3->v_type != V_NUM && v3->v_type != V_NULL) ||
(v4->v_type != V_NUM && v4->v_type != V_NULL))
return error_value(E_QUOMOD_2);
s3 = v3->v_subtype;
s4 = v4->v_subtype;
if ((s3 | s4) & V_NOASSIGNTO)
return error_value(E_QUOMOD_3);
freevalue(v3);
freevalue(v4);
v3->v_type = V_NUM;
v4->v_type = V_NUM;
v3->v_subtype = s3;
v4->v_subtype = s4;
res = qquomod(v1->v_num, v2->v_num, &v3->v_num, &v4->v_num, rnd);
result.v_type = V_NUM;
result.v_subtype = V_NOSUBTYPE;
result.v_num = res ? qlink(&_qone_) : qlink(&_qzero_);
return result;
}
S_FUNC VALUE
f_d2dms(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3, *v4, *v5;
NUMBER *tmp, *tmp_m;
VALUE result;
long rnd;
short s2, s3, s4; /* to preserve subtypes of v2, v3, v4 */
/* collect required args */
v1 = vals[0];
v2 = vals[1];
v3 = vals[2];
v4 = vals[3];
/* determine rounding mode */
if (count == 5) {
v5 = vals[4];
if (v5->v_type == V_ADDR) {
v5 = v5->v_addr;
}
if (v5->v_type != V_NUM || qisfrac(v5->v_num) ||
qisneg(v5->v_num) || zge31b(v5->v_num->num)) {
return error_value(E_D2DMS_4);
}
rnd = qtoi(v5->v_num);
} else {
rnd = conf->quomod;
}
/* type parse args */
if (v2->v_type != V_ADDR || v3->v_type != V_ADDR ||
v4->v_type != V_ADDR) {
return error_value(E_D2DMS_1);
}
if (v1->v_type == V_ADDR) {
v1 = v1->v_addr;
}
v2 = v2->v_addr;
v3 = v3->v_addr;
v4 = v4->v_addr;
if (v1->v_type != V_NUM ||
(v2->v_type != V_NUM && v2->v_type != V_NULL) ||
(v3->v_type != V_NUM && v3->v_type != V_NULL) ||
(v4->v_type != V_NUM && v4->v_type != V_NULL)) {
return error_value(E_D2DMS_2);
}
/* remember arg subtypes */
s2 = v2->v_subtype;
s3 = v3->v_subtype;
s4 = v4->v_subtype;
if ((s2 | s3 | s4) & V_NOASSIGNTO) {
return error_value(E_D2DMS_3);
}
/* free old args that will be modified */
freevalue(v2);
freevalue(v3);
freevalue(v4);
/* set args that will be modified */
v2->v_type = V_NUM;
v3->v_type = V_NUM;
v4->v_type = V_NUM;
/* restore arg subtypes */
v2->v_subtype = s2;
v3->v_subtype = s3;
v4->v_subtype = s4;
/*
* calculate the normalized return value
*
* return_value = mod(degs, 360, rnd);
*/
result.v_type = v1->v_type;
result.v_subtype = v1->v_subtype;
result.v_num = qmod(v1->v_num, &_qthreesixty, rnd);
/*
* integer number of degrees
*
* d = int(return_value);
*/
v2->v_num = qint(result.v_num);
/*
* integer number of minutes
*
* tmp = return_value - d;
* tmp_m = tmp * 60;
* free(tmp);
* m = int(tmp_m);
*/
tmp = qsub(result.v_num, v2->v_num);
tmp_m = qmuli(tmp, 60);
qfree(tmp);
v3->v_num = qint(tmp_m);
/*
* number of seconds
*
* tmp = tmp_m - m;
* free(tmp_m);
* s = tmp * 60;
* free(tmp);
*/
tmp = qsub(tmp_m, v3->v_num);
qfree(tmp_m);
v4->v_num = qmuli(tmp, 60);
qfree(tmp);
/*
* return the normalized value previously calculated
*/
return result;
}
S_FUNC VALUE
f_d2dm(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3, *v4;
NUMBER *tmp;
VALUE result;
long rnd;
short s2, s3; /* to preserve subtypes of v2, v3 */
/* collect required args */
v1 = vals[0];
v2 = vals[1];
v3 = vals[2];
/* determine rounding mode */
if (count == 4) {
v4 = vals[3];
if (v4->v_type == V_ADDR) {
v4 = v4->v_addr;
}
if (v4->v_type != V_NUM || qisfrac(v4->v_num) ||
qisneg(v4->v_num) || zge31b(v4->v_num->num)) {
return error_value(E_D2DM_4);
}
rnd = qtoi(v4->v_num);
} else {
rnd = conf->quomod;
}
/* type parse args */
if (v2->v_type != V_ADDR || v3->v_type != V_ADDR) {
return error_value(E_D2DM_1);
}
if (v1->v_type == V_ADDR) {
v1 = v1->v_addr;
}
v2 = v2->v_addr;
v3 = v3->v_addr;
if (v1->v_type != V_NUM ||
(v2->v_type != V_NUM && v2->v_type != V_NULL) ||
(v3->v_type != V_NUM && v3->v_type != V_NULL)) {
return error_value(E_D2DM_2);
}
/* remember arg subtypes */
s2 = v2->v_subtype;
s3 = v3->v_subtype;
if ((s2 | s3) & V_NOASSIGNTO) {
return error_value(E_D2DM_3);
}
/* free old args that will be modified */
freevalue(v2);
freevalue(v3);
/* set args that will be modified */
v2->v_type = V_NUM;
v3->v_type = V_NUM;
/* restore arg subtypes */
v2->v_subtype = s2;
v3->v_subtype = s3;
/*
* calculate the normalized return value
*
* return_value = mod(degs, 360, rnd);
*/
result.v_type = v1->v_type;
result.v_subtype = v1->v_subtype;
result.v_num = qmod(v1->v_num, &_qthreesixty, rnd);
/*
* integer number of degrees
*
* d = int(return_value);
*/
v2->v_num = qint(result.v_num);
/*
* integer number of minutes
*
* tmp = return_value - d;
* m = tmp * 60;
* free(tmp);
*/
tmp = qsub(result.v_num, v2->v_num);
v3->v_num = qmuli(tmp, 60);
qfree(tmp);
/*
* return the normalized value previously calculated
*/
return result;
}
S_FUNC VALUE
f_g2gms(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3, *v4, *v5;
NUMBER *tmp, *tmp_m;
VALUE result;
long rnd;
short s2, s3, s4; /* to preserve subtypes of v2, v3, v4 */
/* collect required args */
v1 = vals[0];
v2 = vals[1];
v3 = vals[2];
v4 = vals[3];
/* determine rounding mode */
if (count == 5) {
v5 = vals[4];
if (v5->v_type == V_ADDR) {
v5 = v5->v_addr;
}
if (v5->v_type != V_NUM || qisfrac(v5->v_num) ||
qisneg(v5->v_num) || zge31b(v5->v_num->num)) {
return error_value(E_G2GMS_4);
}
rnd = qtoi(v5->v_num);
} else {
rnd = conf->quomod;
}
/* type parse args */
if (v2->v_type != V_ADDR || v3->v_type != V_ADDR ||
v4->v_type != V_ADDR) {
return error_value(E_G2GMS_1);
}
if (v1->v_type == V_ADDR) {
v1 = v1->v_addr;
}
v2 = v2->v_addr;
v3 = v3->v_addr;
v4 = v4->v_addr;
if (v1->v_type != V_NUM ||
(v2->v_type != V_NUM && v2->v_type != V_NULL) ||
(v3->v_type != V_NUM && v3->v_type != V_NULL) ||
(v4->v_type != V_NUM && v4->v_type != V_NULL)) {
return error_value(E_G2GMS_2);
}
/* remember arg subtypes */
s2 = v2->v_subtype;
s3 = v3->v_subtype;
s4 = v4->v_subtype;
if ((s2 | s3 | s4) & V_NOASSIGNTO) {
return error_value(E_G2GMS_3);
}
/* free old args that will be modified */
freevalue(v2);
freevalue(v3);
freevalue(v4);
/* set args that will be modified */
v2->v_type = V_NUM;
v3->v_type = V_NUM;
v4->v_type = V_NUM;
/* restore arg subtypes */
v2->v_subtype = s2;
v3->v_subtype = s3;
v4->v_subtype = s4;
/*
* calculate the normalized return value
*
* return_value = mod(grads, 400, rnd);
*/
result.v_type = v1->v_type;
result.v_subtype = v1->v_subtype;
result.v_num = qmod(v1->v_num, &_qfourhundred, rnd);
/*
* integer number of gradians
*
* g = int(return_value);
*/
v2->v_num = qint(result.v_num);
/*
* integer number of minutes
*
* tmp = return_value - g;
* tmp_m = tmp * 60;
* free(tmp);
* m = int(tmp_m);
*/
tmp = qsub(result.v_num, v2->v_num);
tmp_m = qmuli(tmp, 60);
qfree(tmp);
v3->v_num = qint(tmp_m);
/*
* number of seconds
*
* tmp = tmp_m - m;
* free(tmp_m);
* s = tmp * 60;
* free(tmp);
*/
tmp = qsub(tmp_m, v3->v_num);
qfree(tmp_m);
v4->v_num = qmuli(tmp, 60);
qfree(tmp);
/*
* return the normalized value previously calculated
*/
return result;
}
S_FUNC VALUE
f_g2gm(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3, *v4;
NUMBER *tmp;
VALUE result;
long rnd;
short s2, s3; /* to preserve subtypes of v2, v3 */
/* collect required args */
v1 = vals[0];
v2 = vals[1];
v3 = vals[2];
/* determine rounding mode */
if (count == 4) {
v4 = vals[3];
if (v4->v_type == V_ADDR) {
v4 = v4->v_addr;
}
if (v4->v_type != V_NUM || qisfrac(v4->v_num) ||
qisneg(v4->v_num) || zge31b(v4->v_num->num)) {
return error_value(E_G2GM_4);
}
rnd = qtoi(v4->v_num);
} else {
rnd = conf->quomod;
}
/* type parse args */
if (v2->v_type != V_ADDR || v3->v_type != V_ADDR) {
return error_value(E_G2GM_1);
}
if (v1->v_type == V_ADDR) {
v1 = v1->v_addr;
}
v2 = v2->v_addr;
v3 = v3->v_addr;
if (v1->v_type != V_NUM ||
(v2->v_type != V_NUM && v2->v_type != V_NULL) ||
(v3->v_type != V_NUM && v3->v_type != V_NULL)) {
return error_value(E_G2GM_2);
}
/* remember arg subtypes */
s2 = v2->v_subtype;
s3 = v3->v_subtype;
if ((s2 | s3) & V_NOASSIGNTO) {
return error_value(E_G2GM_3);
}
/* free old args that will be modified */
freevalue(v2);
freevalue(v3);
/* set args that will be modified */
v2->v_type = V_NUM;
v3->v_type = V_NUM;
/* restore arg subtypes */
v2->v_subtype = s2;
v3->v_subtype = s3;
/*
* calculate the normalized return value
*
* return_value = mod(grads, 400, rnd);
*/
result.v_type = v1->v_type;
result.v_subtype = v1->v_subtype;
result.v_num = qmod(v1->v_num, &_qfourhundred, rnd);
/*
* integer number of gradians
*
* g = int(return_value);
*/
v2->v_num = qint(result.v_num);
/*
* integer number of minutes
*
* tmp = return_value - g;
* m = tmp * 60;
* free(tmp);
*/
tmp = qsub(result.v_num, v2->v_num);
v3->v_num = qmuli(tmp, 60);
qfree(tmp);
/*
* return the normalized value previously calculated
*/
return result;
}
S_FUNC VALUE
f_h2hms(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3, *v4, *v5;
NUMBER *tmp, *tmp_m;
VALUE result;
long rnd;
short s2, s3, s4; /* to preserve subtypes of v2, v3, v4 */
/* collect required args */
v1 = vals[0];
v2 = vals[1];
v3 = vals[2];
v4 = vals[3];
/* determine rounding mode */
if (count == 5) {
v5 = vals[4];
if (v5->v_type == V_ADDR) {
v5 = v5->v_addr;
}
if (v5->v_type != V_NUM || qisfrac(v5->v_num) ||
qisneg(v5->v_num) || zge31b(v5->v_num->num)) {
return error_value(E_H2HMS_4);
}
rnd = qtoi(v5->v_num);
} else {
rnd = conf->quomod;
}
/* type parse args */
if (v2->v_type != V_ADDR || v3->v_type != V_ADDR ||
v4->v_type != V_ADDR) {
return error_value(E_H2HMS_1);
}
if (v1->v_type == V_ADDR) {
v1 = v1->v_addr;
}
v2 = v2->v_addr;
v3 = v3->v_addr;
v4 = v4->v_addr;
if (v1->v_type != V_NUM ||
(v2->v_type != V_NUM && v2->v_type != V_NULL) ||
(v3->v_type != V_NUM && v3->v_type != V_NULL) ||
(v4->v_type != V_NUM && v4->v_type != V_NULL)) {
return error_value(E_H2HMS_2);
}
/* remember arg subtypes */
s2 = v2->v_subtype;
s3 = v3->v_subtype;
s4 = v4->v_subtype;
if ((s2 | s3 | s4) & V_NOASSIGNTO) {
return error_value(E_H2HMS_3);
}
/* free old args that will be modified */
freevalue(v2);
freevalue(v3);
freevalue(v4);
/* set args that will be modified */
v2->v_type = V_NUM;
v3->v_type = V_NUM;
v4->v_type = V_NUM;
/* restore arg subtypes */
v2->v_subtype = s2;
v3->v_subtype = s3;
v4->v_subtype = s4;
/*
* calculate the normalized return value
*
* return_value = mod(hours, 24, rnd);
*/
result.v_type = v1->v_type;
result.v_subtype = v1->v_subtype;
result.v_num = qmod(v1->v_num, &_qtwentyfour, rnd);
/*
* integer number of hours
*
* h = int(return_value);
*/
v2->v_num = qint(result.v_num);
/*
* integer number of minutes
*
* tmp = return_value - h;
* tmp_m = tmp * 60;
* free(tmp);
* m = int(tmp_m);
*/
tmp = qsub(result.v_num, v2->v_num);
tmp_m = qmuli(tmp, 60);
qfree(tmp);
v3->v_num = qint(tmp_m);
/*
* number of seconds
*
* tmp = tmp_m - m;
* free(tmp_m);
* s = tmp * 60;
* free(tmp);
*/
tmp = qsub(tmp_m, v3->v_num);
qfree(tmp_m);
v4->v_num = qmuli(tmp, 60);
qfree(tmp);
/*
* return the normalized value previously calculated
*/
return result;
}
S_FUNC VALUE
f_h2hm(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3, *v4;
NUMBER *tmp;
VALUE result;
long rnd;
short s2, s3; /* to preserve subtypes of v2, v3 */
/* collect required args */
v1 = vals[0];
v2 = vals[1];
v3 = vals[2];
/* determine rounding mode */
if (count == 4) {
v4 = vals[3];
if (v4->v_type == V_ADDR) {
v4 = v4->v_addr;
}
if (v4->v_type != V_NUM || qisfrac(v4->v_num) ||
qisneg(v4->v_num) || zge31b(v4->v_num->num)) {
return error_value(E_H2HM_4);
}
rnd = qtoi(v4->v_num);
} else {
rnd = conf->quomod;
}
/* type parse args */
if (v2->v_type != V_ADDR || v3->v_type != V_ADDR) {
return error_value(E_H2HM_1);
}
if (v1->v_type == V_ADDR) {
v1 = v1->v_addr;
}
v2 = v2->v_addr;
v3 = v3->v_addr;
if (v1->v_type != V_NUM ||
(v2->v_type != V_NUM && v2->v_type != V_NULL) ||
(v3->v_type != V_NUM && v3->v_type != V_NULL)) {
return error_value(E_H2HM_2);
}
/* remember arg subtypes */
s2 = v2->v_subtype;
s3 = v3->v_subtype;
if ((s2 | s3) & V_NOASSIGNTO) {
return error_value(E_H2HM_3);
}
/* free old args that will be modified */
freevalue(v2);
freevalue(v3);
/* set args that will be modified */
v2->v_type = V_NUM;
v3->v_type = V_NUM;
/* restore arg subtypes */
v2->v_subtype = s2;
v3->v_subtype = s3;
/*
* calculate the normalized return value
*
* return_value = mod(hours, 24, rnd);
*/
result.v_type = v1->v_type;
result.v_subtype = v1->v_subtype;
result.v_num = qmod(v1->v_num, &_qtwentyfour, rnd);
/*
* integer number of gradians
*
* h = int(return_value);
*/
v2->v_num = qint(result.v_num);
/*
* integer number of minutes
*
* tmp = return_value - h;
* m = tmp * 60;
* free(tmp);
*/
tmp = qsub(result.v_num, v2->v_num);
v3->v_num = qmuli(tmp, 60);
qfree(tmp);
/*
* return the normalized value previously calculated
*/
return result;
}
S_FUNC VALUE
f_dms2d(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3, *v4;
NUMBER *tmp, *tmp2, *tmp3, *tmp4;
VALUE result;
long rnd;
/* collect required args */
v1 = vals[0];
v2 = vals[1];
v3 = vals[2];
/* determine rounding mode */
if (count == 4) {
v4 = vals[3];
if (v4->v_type == V_ADDR) {
v4 = v4->v_addr;
}
if (v4->v_type != V_NUM || qisfrac(v4->v_num) ||
qisneg(v4->v_num) || zge31b(v4->v_num->num)) {
return error_value(E_DMS2D_2);
}
rnd = qtoi(v4->v_num);
} else {
rnd = conf->quomod;
}
/* type parse args */
if (v1->v_type != V_NUM || v2->v_type != V_NUM ||
v3->v_type != V_NUM) {
return error_value(E_DMS2D_1);
}
/*
* compute s/3600
*/
tmp = qdivi(v3->v_num, 3600);
/*
* compute m/60
*/
tmp2 = qdivi(v2->v_num, 60);
/*
* compute m/60 + s/3600
*/
tmp3 = qqadd(tmp2, tmp);
qfree(tmp);
qfree(tmp2);
/*
* compute d + m/60 + s/3600
*/
tmp4 = qqadd(v1->v_num, tmp3);
qfree(tmp3);
/*
* compute mod(d + m/60 + s/3600, 360, rnd);
*/
result.v_type = v1->v_type;
result.v_subtype = v1->v_subtype;
result.v_num = qmod(tmp4, &_qthreesixty, rnd);
qfree(tmp4);
/*
* return mod(d + m/60 + s/3600, 360, rnd);
*/
return result;
}
S_FUNC VALUE
f_dm2d(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3;
NUMBER *tmp, *tmp2;
VALUE result;
long rnd;
/* collect required args */
v1 = vals[0];
v2 = vals[1];
/* determine rounding mode */
if (count == 3) {
v3 = vals[2];
if (v3->v_type == V_ADDR) {
v3 = v3->v_addr;
}
if (v3->v_type != V_NUM || qisfrac(v3->v_num) ||
qisneg(v3->v_num) || zge31b(v3->v_num->num)) {
return error_value(E_DM2D_2);
}
rnd = qtoi(v3->v_num);
} else {
rnd = conf->quomod;
}
/* type parse args */
if (v1->v_type != V_NUM || v2->v_type != V_NUM) {
return error_value(E_DM2D_1);
}
/*
* compute m/60
*/
tmp = qdivi(v2->v_num, 60);
/*
* compute d + m/60
*/
tmp2 = qqadd(v1->v_num, tmp);
qfree(tmp);
/*
* compute mod(d + m/60, 360, rnd);
*/
result.v_type = v1->v_type;
result.v_subtype = v1->v_subtype;
result.v_num = qmod(tmp2, &_qthreesixty, rnd);
qfree(tmp2);
/*
* return mod(d + m/60, 360, rnd);
*/
return result;
}
S_FUNC VALUE
f_gms2g(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3, *v4;
NUMBER *tmp, *tmp2, *tmp3, *tmp4;
VALUE result;
long rnd;
/* collect required args */
v1 = vals[0];
v2 = vals[1];
v3 = vals[2];
/* determine rounding mode */
if (count == 4) {
v4 = vals[3];
if (v4->v_type == V_ADDR) {
v4 = v4->v_addr;
}
if (v4->v_type != V_NUM || qisfrac(v4->v_num) ||
qisneg(v4->v_num) || zge31b(v4->v_num->num)) {
return error_value(E_GMS2G_2);
}
rnd = qtoi(v4->v_num);
} else {
rnd = conf->quomod;
}
/* type parse args */
if (v1->v_type != V_NUM || v2->v_type != V_NUM ||
v3->v_type != V_NUM) {
return error_value(E_GMS2G_1);
}
/*
* compute s/3600
*/
tmp = qdivi(v3->v_num, 3600);
/*
* compute m/60
*/
tmp2 = qdivi(v2->v_num, 60);
/*
* compute m/60 + s/3600
*/
tmp3 = qqadd(tmp2, tmp);
qfree(tmp);
qfree(tmp2);
/*
* compute g + m/60 + s/3600
*/
tmp4 = qqadd(v1->v_num, tmp3);
qfree(tmp3);
/*
* compute mod(g + m/60 + s/3600, 400, rnd);
*/
result.v_type = v1->v_type;
result.v_subtype = v1->v_subtype;
result.v_num = qmod(tmp4, &_qfourhundred, rnd);
qfree(tmp4);
/*
* return mod(g + m/60 + s/3600, 400, rnd);
*/
return result;
}
S_FUNC VALUE
f_gm2g(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3;
NUMBER *tmp, *tmp2;
VALUE result;
long rnd;
/* collect required args */
v1 = vals[0];
v2 = vals[1];
/* determine rounding mode */
if (count == 3) {
v3 = vals[2];
if (v3->v_type == V_ADDR) {
v3 = v3->v_addr;
}
if (v3->v_type != V_NUM || qisfrac(v3->v_num) ||
qisneg(v3->v_num) || zge31b(v3->v_num->num)) {
return error_value(E_GM2G_2);
}
rnd = qtoi(v3->v_num);
} else {
rnd = conf->quomod;
}
/* type parse args */
if (v1->v_type != V_NUM || v2->v_type != V_NUM) {
return error_value(E_GM2G_1);
}
/*
* compute m/60
*/
tmp = qdivi(v2->v_num, 60);
/*
* compute g + m/60
*/
tmp2 = qqadd(v1->v_num, tmp);
qfree(tmp);
/*
* compute mod(g + m/60, 400, rnd);
*/
result.v_type = v1->v_type;
result.v_subtype = v1->v_subtype;
result.v_num = qmod(tmp2, &_qfourhundred, rnd);
qfree(tmp2);
/*
* return mod(g + m/60, 400, rnd);
*/
return result;
}
S_FUNC VALUE
f_hms2h(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3, *v4;
NUMBER *tmp, *tmp2, *tmp3, *tmp4;
VALUE result;
long rnd;
/* collect required args */
v1 = vals[0];
v2 = vals[1];
v3 = vals[2];
/* determine rounding mode */
if (count == 4) {
v4 = vals[3];
if (v4->v_type == V_ADDR) {
v4 = v4->v_addr;
}
if (v4->v_type != V_NUM || qisfrac(v4->v_num) ||
qisneg(v4->v_num) || zge31b(v4->v_num->num)) {
return error_value(E_HMS2H_2);
}
rnd = qtoi(v4->v_num);
} else {
rnd = conf->quomod;
}
/* type parse args */
if (v1->v_type != V_NUM || v2->v_type != V_NUM ||
v3->v_type != V_NUM) {
return error_value(E_HMS2H_1);
}
/*
* compute s/3600
*/
tmp = qdivi(v3->v_num, 3600);
/*
* compute m/60
*/
tmp2 = qdivi(v2->v_num, 60);
/*
* compute m/60 + s/3600
*/
tmp3 = qqadd(tmp2, tmp);
qfree(tmp);
qfree(tmp2);
/*
* compute h + m/60 + s/3600
*/
tmp4 = qqadd(v1->v_num, tmp3);
qfree(tmp3);
/*
* compute mod(h + m/60 + s/3600, 24, rnd);
*/
result.v_type = v1->v_type;
result.v_subtype = v1->v_subtype;
result.v_num = qmod(tmp4, &_qtwentyfour, rnd);
qfree(tmp4);
/*
* return mod(d + m/60 + s/3600, 24, rnd);
*/
return result;
}
S_FUNC VALUE
f_hm2h(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3;
NUMBER *tmp, *tmp2;
VALUE result;
long rnd;
/* collect required args */
v1 = vals[0];
v2 = vals[1];
/* determine rounding mode */
if (count == 3) {
v3 = vals[2];
if (v3->v_type == V_ADDR) {
v3 = v3->v_addr;
}
if (v3->v_type != V_NUM || qisfrac(v3->v_num) ||
qisneg(v3->v_num) || zge31b(v3->v_num->num)) {
return error_value(E_H2HM_2);
}
rnd = qtoi(v3->v_num);
} else {
rnd = conf->quomod;
}
/* type parse args */
if (v1->v_type != V_NUM || v2->v_type != V_NUM) {
return error_value(E_H2HM_1);
}
/*
* compute m/60
*/
tmp = qdivi(v2->v_num, 60);
/*
* compute d + m/60
*/
tmp2 = qqadd(v1->v_num, tmp);
qfree(tmp);
/*
* compute mod(h + m/60, 24, rnd);
*/
result.v_type = v1->v_type;
result.v_subtype = v1->v_subtype;
result.v_num = qmod(tmp2, &_qtwentyfour, rnd);
qfree(tmp2);
/*
* return mod(h + m/60, 24, rnd);
*/
return result;
}
S_FUNC VALUE
f_mmin(VALUE *v1, VALUE *v2)
{
VALUE sixteen, res;
/* initialize VALUEs */
sixteen.v_subtype = V_NOSUBTYPE;
res.v_subtype = V_NOSUBTYPE;
sixteen.v_type = V_NUM;
sixteen.v_num = itoq(16);
modvalue(v1, v2, &sixteen, &res);
qfree(sixteen.v_num);
return res;
}
S_FUNC NUMBER *
f_near(int count, NUMBER **vals)
{
NUMBER *err; /* epsilon error tolerance */
FLAG near; /* qnear() return value */
NUMBER *ret; /* return value as NUMBER */
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
err = conf->epsilon;
if (count == 3) {
if (check_epsilon(vals[2]) == false) {
math_error("Invalid value for near epsilon: must be: 0 < epsilon < 1");
not_reached();
}
err = vals[2];
}
/*
* compute compare nearness of two numbers to a given error tolerance
*/
near = qnear(vals[0], vals[1], err);
ret = itoq((long) near);
return ret;
}
S_FUNC NUMBER *
f_cfsim(int count, NUMBER **vals)
{
long R;
R = (count > 1) ? qtoi(vals[1]) : conf->cfsim;
return qcfsim(vals[0], R);
}
S_FUNC NUMBER *
f_cfappr(int count, NUMBER **vals)
{
long R;
NUMBER *q; /* approximation limit */
/*
* determine epsilon or and approximation limit
*
* NOTE: q is not purely an err (epsilon) value.
* When q is >= 1, it is approximation limit.
* Moreover q can be < 0. No value check on q is needed.
*/
q = (count > 1) ? vals[1] : conf->epsilon;
/*
* compute approximation using continued fractions
*/
R = (count > 2) ? qtoi(vals[2]) : conf->cfappr;
return qcfappr(vals[0], q, R);
}
S_FUNC VALUE
f_ceil(VALUE *val)
{
VALUE tmp, res;
/* initialize VALUEs */
res.v_subtype = V_NOSUBTYPE;
tmp.v_subtype = V_NOSUBTYPE;
tmp.v_type = V_NUM;
tmp.v_num = qlink(&_qone_);
apprvalue(val, &tmp, &tmp, &res);
return res;
}
S_FUNC VALUE
f_floor(VALUE *val)
{
VALUE tmp1, tmp2, res;
/* initialize VALUEs */
res.v_subtype = V_NOSUBTYPE;
tmp1.v_subtype = V_NOSUBTYPE;
tmp2.v_subtype = V_NOSUBTYPE;
tmp1.v_type = V_NUM;
tmp1.v_num = qlink(&_qone_);
tmp2.v_type = V_NUM;
tmp2.v_num = qlink(&_qzero_);
apprvalue(val, &tmp1, &tmp2, &res);
return res;
}
S_FUNC VALUE
f_sqrt(int count, VALUE **vals)
{
VALUE tmp1, tmp2, result;
/* initialize VALUEs */
result.v_subtype = V_NOSUBTYPE;
tmp1.v_subtype = V_NOSUBTYPE;
tmp2.v_subtype = V_NOSUBTYPE;
if (count > 2)
tmp2 = *vals[2];
else
tmp2.v_type = V_NULL;
if (count > 1)
tmp1 = *vals[1];
else
tmp1.v_type = V_NULL;
sqrtvalue(vals[0], &tmp1, &tmp2, &result);
return result;
}
S_FUNC VALUE
f_root(int count, VALUE **vals)
{
VALUE *vp, err, result;
/* initialize VALUEs */
err.v_subtype = V_NOSUBTYPE;
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is != 0.
*/
if (count > 2) {
vp = vals[2];
} else {
err.v_num = conf->epsilon;
err.v_type = V_NUM;
vp = &err;
}
if (vp->v_type != V_NUM || qiszero(vp->v_num)) {
return error_value(E_ROOT_3);
}
/*
* compute root of a number to a given error tolerance
*/
rootvalue(vals[0], vals[1], vp, &result);
return result;
}
S_FUNC VALUE
f_power(int count, VALUE **vals)
{
VALUE *vp, err, result;
/* initialize VALUEs */
err.v_subtype = V_NOSUBTYPE;
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is != 0.
*/
if (count > 2) {
vp = vals[2];
} else {
err.v_num = conf->epsilon;
err.v_type = V_NUM;
vp = &err;
}
if ((vp->v_type != V_NUM) || qisneg(vp->v_num) || qiszero(vp->v_num)) {
return error_value(E_POWER_3);
}
/*
* compute evaluate a numerical power to a given error tolerance
*/
powervalue(vals[0], vals[1], vp, &result);
return result;
}
S_FUNC VALUE
f_polar(int count, VALUE **vals)
{
VALUE *vp, err, result;
COMPLEX *c;
/* initialize VALUEs */
err.v_subtype = V_NOSUBTYPE;
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is != 0.
*/
if (count > 2) {
vp = vals[2];
if ((vp->v_type != V_NUM) || qisneg(vp->v_num) || qiszero(vp->v_num)) {
return error_value(E_POLAR_2);
}
} else {
err.v_num = conf->epsilon;
err.v_type = V_NUM;
vp = &err;
}
if ((vp->v_type != V_NUM) || qisneg(vp->v_num) || qiszero(vp->v_num)) {
return error_value(E_POLAR_2);
}
/*
* compute complex number by modulus (radius) and argument (angle) to a given error tolerance
*/
if ((vals[0]->v_type != V_NUM) || (vals[1]->v_type != V_NUM))
return error_value(E_POLAR_1);
c = c_polar(vals[0]->v_num, vals[1]->v_num, vp->v_num);
result.v_com = c;
result.v_type = V_COM;
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
return result;
}
S_FUNC VALUE
f_ilog(VALUE *v1, VALUE *v2)
{
VALUE res;
if (v2->v_type != V_NUM || qisfrac(v2->v_num) || qiszero(v2->v_num) ||
qisunit(v2->v_num))
return error_value(E_ILOGB);
switch(v1->v_type) {
case V_NUM:
res.v_num = qilog(v1->v_num, v2->v_num->num);
break;
case V_COM:
res.v_num = c_ilog(v1->v_com, v2->v_num->num);
break;
default:
return error_value(E_ILOG);
}
if (res.v_num == NULL)
return error_value(E_LOGINF);
res.v_type = V_NUM;
res.v_subtype = V_NOSUBTYPE;
return res;
}
S_FUNC VALUE
f_ilog2(VALUE *vp)
{
VALUE res;
switch(vp->v_type) {
case V_NUM:
res.v_num = qilog(vp->v_num, _two_);
break;
case V_COM:
res.v_num = c_ilog(vp->v_com, _two_);
break;
default:
return error_value(E_IBASE2_LOG);
}
if (res.v_num == NULL)
return error_value(E_LOGINF);
res.v_type = V_NUM;
res.v_subtype = V_NOSUBTYPE;
return res;
}
S_FUNC VALUE
f_ilog10(VALUE *vp)
{
VALUE res;
switch(vp->v_type) {
case V_NUM:
res.v_num = qilog(vp->v_num, _ten_);
break;
case V_COM:
res.v_num = c_ilog(vp->v_com, _ten_);
break;
default:
return error_value(E_IBASE10_LOG);
}
if (res.v_num == NULL)
return error_value(E_LOGINF);
res.v_type = V_NUM;
res.v_subtype = V_NOSUBTYPE;
return res;
}
S_FUNC NUMBER *
f_faccnt(NUMBER *val1, NUMBER *val2)
{
if (qisfrac(val1) || qisfrac(val2))
math_error("Non-integral argument for fcnt");
return itoq(zdivcount(val1->num, val2->num));
}
S_FUNC VALUE
f_matfill(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
v1 = vals[0];
v2 = vals[1];
if (v1->v_type != V_ADDR)
return error_value(E_MATFILL_1);
v1 = v1->v_addr;
if (v1->v_subtype & V_NOCOPYTO)
return error_value(E_MATFILL_3);
if (v1->v_type != V_MAT)
return error_value(E_MATFILL_2);
if (v2->v_type == V_ADDR)
v2 = v2->v_addr;
if (v2->v_subtype & V_NOASSIGNFROM)
return error_value(E_MATFILL_4);
if (count == 3) {
v3 = vals[2];
if (v3->v_type == V_ADDR)
v3 = v3->v_addr;
if (v3->v_subtype & V_NOASSIGNFROM)
return error_value(E_MATFILL_4);
}
else
v3 = NULL;
matfill(v1->v_mat, v2, v3);
result.v_type = V_NULL;
return result;
}
S_FUNC VALUE
f_matsum(VALUE *vp)
{
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/* firewall */
if (vp->v_type != V_MAT)
return error_value(E_MATSUM);
/* sum matrix */
matsum(vp->v_mat, &result);
return result;
}
S_FUNC VALUE
f_isident(VALUE *vp)
{
VALUE result;
/* initialize VALUEs */
result.v_type = V_NUM;
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type == V_MAT) {
result.v_num = itoq((long) matisident(vp->v_mat));
} else {
result.v_num = itoq(0);
}
return result;
}
S_FUNC VALUE
f_mattrace(VALUE *vp)
{
if (vp->v_type != V_MAT)
return error_value(E_MATTRACE_1);
return mattrace(vp->v_mat);
}
S_FUNC VALUE
f_mattrans(VALUE *vp)
{
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_MAT)
return error_value(E_MATTRANS_1);
if (vp->v_mat->m_dim > 2)
return error_value(E_MATTRANS_2);
result.v_type = V_MAT;
result.v_mat = mattrans(vp->v_mat);
return result;
}
S_FUNC VALUE
f_det(VALUE *vp)
{
if (vp->v_type != V_MAT)
return error_value(E_DET_1);
return matdet(vp->v_mat);
}
S_FUNC VALUE
f_matdim(VALUE *vp)
{
VALUE result;
/* initialize VALUEs */
result.v_type = V_NUM;
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_OBJ:
result.v_num = itoq(vp->v_obj->o_actions->oa_count);
break;
case V_MAT:
result.v_num = itoq((long) vp->v_mat->m_dim);
break;
default:
return error_value(E_MATDIM);
}
return result;
}
S_FUNC VALUE
f_matmin(VALUE *v1, VALUE *v2)
{
VALUE result;
NUMBER *q;
long i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (v1->v_type != V_MAT)
return error_value(E_MATMIN_1);
if (v2->v_type != V_NUM)
return error_value(E_MATMIN_2);
q = v2->v_num;
if (qisfrac(q) || qisneg(q) || qiszero(q))
return error_value(E_MATMIN_2);
i = qtoi(q);
if (i > v1->v_mat->m_dim)
return error_value(E_MATMIN_3);
result.v_type = V_NUM;
result.v_num = itoq(v1->v_mat->m_min[i - 1]);
return result;
}
S_FUNC VALUE
f_matmax(VALUE *v1, VALUE *v2)
{
VALUE result;
NUMBER *q;
long i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (v1->v_type != V_MAT)
return error_value(E_MATMAX_1);
if (v2->v_type != V_NUM)
return error_value(E_MATMAX_2);
q = v2->v_num;
if (qisfrac(q) || qisneg(q) || qiszero(q))
return error_value(E_MATMAX_2);
i = qtoi(q);
if (i > v1->v_mat->m_dim)
return error_value(E_MATMAX_3);
result.v_type = V_NUM;
result.v_num = itoq(v1->v_mat->m_max[i - 1]);
return result;
}
S_FUNC VALUE
f_cp(VALUE *v1, VALUE *v2)
{
MATRIX *m1, *m2;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT))
return error_value(E_CP_1);
m1 = v1->v_mat;
m2 = v2->v_mat;
if ((m1->m_dim != 1) || (m2->m_dim != 1))
return error_value(E_CP_2);
if ((m1->m_size != 3) || (m2->m_size != 3))
return error_value(E_CP_3);
result.v_type = V_MAT;
result.v_mat = matcross(m1, m2);
return result;
}
S_FUNC VALUE
f_dp(VALUE *v1, VALUE *v2)
{
MATRIX *m1, *m2;
if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT))
return error_value(E_DP_1);
m1 = v1->v_mat;
m2 = v2->v_mat;
if ((m1->m_dim != 1) || (m2->m_dim != 1))
return error_value(E_DP_2);
if (m1->m_size != m2->m_size)
return error_value(E_DP_3);
return matdot(m1, m2);
}
S_FUNC VALUE
f_strlen(VALUE *vp)
{
VALUE result;
long len = 0;
char *c;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_STR)
return error_value(E_STRLEN);
c = vp->v_str->s_str;
while (*c++)
len++;
result.v_type = V_NUM;
result.v_num = itoq(len);
return result;
}
S_FUNC VALUE
f_strcmp(VALUE *v1, VALUE *v2)
{
VALUE result;
FLAG flag;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (v1->v_type != V_STR || v2->v_type != V_STR)
return error_value(E_STRCMP);
flag = stringrel(v1->v_str, v2->v_str);
result.v_type = V_NUM;
result.v_num = itoq((long) flag);
return result;
}
S_FUNC VALUE
f_strcasecmp(VALUE *v1, VALUE *v2)
{
VALUE result;
FLAG flag;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (v1->v_type != V_STR || v2->v_type != V_STR)
return error_value(E_STRCASECMP);
flag = stringcaserel(v1->v_str, v2->v_str);
result.v_type = V_NUM;
result.v_num = itoq((long) flag);
return result;
}
S_FUNC VALUE
f_strncmp(VALUE *v1, VALUE *v2, VALUE *v3)
{
long n1, n2, n;
FLAG flag;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (v1->v_type != V_STR || v2->v_type != V_STR ||
v3->v_type != V_NUM || qisneg(v3->v_num) ||
qisfrac(v3->v_num) || zge31b(v3->v_num->num))
return error_value(E_STRNCMP);
n1 = v1->v_str->s_len;
n2 = v2->v_str->s_len;
n = qtoi(v3->v_num);
if (n < n1)
v1->v_str->s_len = n;
if (n < n2)
v2->v_str->s_len = n;
flag = stringrel(v1->v_str, v2->v_str);
v1->v_str->s_len = n1;
v2->v_str->s_len = n2;
result.v_type = V_NUM;
result.v_num = itoq((long) flag);
return result;
}
S_FUNC VALUE
f_strncasecmp(VALUE *v1, VALUE *v2, VALUE *v3)
{
long n1, n2, n;
FLAG flag;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (v1->v_type != V_STR || v2->v_type != V_STR ||
v3->v_type != V_NUM || qisneg(v3->v_num) ||
qisfrac(v3->v_num) || zge31b(v3->v_num->num))
return error_value(E_STRNCASECMP);
n1 = v1->v_str->s_len;
n2 = v2->v_str->s_len;
n = qtoi(v3->v_num);
if (n < n1)
v1->v_str->s_len = n;
if (n < n2)
v2->v_str->s_len = n;
flag = stringcaserel(v1->v_str, v2->v_str);
v1->v_str->s_len = n1;
v2->v_str->s_len = n2;
result.v_type = V_NUM;
result.v_num = itoq((long) flag);
return result;
}
S_FUNC VALUE
f_strtoupper(VALUE *vp)
{
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_STR)
return error_value(E_STRTOUPPER);
result.v_str = stringtoupper(vp->v_str);
result.v_type = V_STR;
return result;
}
S_FUNC VALUE
f_strtolower(VALUE *vp)
{
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_STR)
return error_value(E_STRTOLOWER);
result.v_str = stringtolower(vp->v_str);
result.v_type = V_STR;
return result;
}
S_FUNC VALUE
f_strcat(int count, VALUE **vals)
{
VALUE **vp;
char *c, *c1;
int i;
long len;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
len = 0;
result.v_type = V_STR;
vp = vals;
for (i = 0; i < count; i++, vp++) {
if ((*vp)->v_type != V_STR)
return error_value(E_STRCAT);
c = (*vp)->v_str->s_str;
while (*c++)
len++;
}
if (len == 0) {
result.v_str = slink(&_nullstring_);
return result;
}
c = (char *) malloc(len + 1) ;
if (c == NULL) {
math_error("No memory for strcat");
not_reached();
}
result.v_str = stralloc();
result.v_str->s_str = c;
result.v_str->s_len = len;
for (vp = vals; count-- > 0; vp++) {
c1 = (*vp)->v_str->s_str;
while (*c1)
*c++ = *c1++;
}
*c = '\0';
return result;
}
S_FUNC VALUE
f_strcpy(VALUE *v1, VALUE *v2)
{
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (v1->v_type != V_STR || v2->v_type != V_STR)
return error_value(E_STRCPY);
result.v_str = stringcpy(v1->v_str, v2->v_str);
result.v_type = V_STR;
return result;
}
S_FUNC VALUE
f_strncpy(VALUE *v1, VALUE *v2, VALUE *v3)
{
VALUE result;
long num;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (v1->v_type != V_STR || v2->v_type != V_STR ||
v3->v_type != V_NUM || qisfrac(v3->v_num) || qisneg(v3->v_num))
return error_value(E_STRNCPY);
if (zge31b(v3->v_num->num))
num = v2->v_str->s_len;
else
num = qtoi(v3->v_num);
result.v_str = stringncpy(v1->v_str, v2->v_str, num);
result.v_type = V_STR;
return result;
}
S_FUNC VALUE
f_substr(VALUE *v1, VALUE *v2, VALUE *v3)
{
NUMBER *q1, *q2;
size_t start, len;
char *cp;
char *ccp;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (v1->v_type != V_STR)
return error_value(E_SUBSTR_1);
if ((v2->v_type != V_NUM) || (v3->v_type != V_NUM))
return error_value(E_SUBSTR_2);
q1 = v2->v_num;
q2 = v3->v_num;
if (qisfrac(q1) || qisneg(q1) || qisfrac(q2) || qisneg(q2))
return error_value(E_SUBSTR_2);
start = qtoi(q1);
len = qtoi(q2);
if (start > 0)
start--;
result.v_type = V_STR;
if (start >= v1->v_str->s_len || len == 0) {
result.v_str = slink(&_nullstring_);
return result;
}
if (len > v1->v_str->s_len - start)
len = v1->v_str->s_len - start;
cp = v1->v_str->s_str + start;
ccp = (char *) malloc(len + 1);
if (ccp == NULL) {
math_error("No memory for substr");
not_reached();
}
result.v_str = stralloc();
result.v_str->s_len = len;
result.v_str->s_str = ccp;
while (len-- > 0)
*ccp++ = *cp++;
*ccp = '\0';
return result;
}
S_FUNC VALUE
f_char(VALUE *vp)
{
char ch;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_NUM:
if (qisfrac(vp->v_num))
return error_value(E_CHAR);
ch = (char) vp->v_num->num.v[0];
if (qisneg(vp->v_num))
ch = -ch;
break;
case V_OCTET:
ch = *vp->v_octet;
break;
case V_STR:
ch = *vp->v_str->s_str;
break;
default:
return error_value(E_CHAR);
}
result.v_type = V_STR;
result.v_str = charstring(ch);
return result;
}
S_FUNC VALUE
f_ord(VALUE *vp)
{
OCTET *c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = (OCTET *)vp->v_str->s_str;
break;
case V_OCTET:
c = vp->v_octet;
break;
default:
return error_value(E_ORD);
}
result.v_type = V_NUM;
result.v_num = itoq((long) (*c & 0xff));
return result;
}
S_FUNC VALUE
f_isupper(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISUPPER);
}
result.v_type = V_NUM;
result.v_num = itoq( (isupper( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_islower(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISLOWER);
}
result.v_type = V_NUM;
result.v_num = itoq( (islower( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_isalnum(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISALNUM);
}
result.v_type = V_NUM;
result.v_num = itoq( (isalnum( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_isalpha(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISALPHA);
}
result.v_type = V_NUM;
result.v_num = itoq( (isalpha( c ))?1l:0l);
return result;
}
#if 0 /* XXX - add isascii builtin funcion - XXX */
S_FUNC VALUE
f_isascii(VALUE *vp)
{
char c;
VALUE result;
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISASCII);
}
result.v_type = V_NUM;
result.v_num = itoq( (isascii( c ))?1l:0l);
return result;
}
#endif /* 0 */
S_FUNC VALUE
f_iscntrl(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISCNTRL);
}
result.v_type = V_NUM;
result.v_num = itoq( (iscntrl( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_isdigit(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISDIGIT);
}
result.v_type = V_NUM;
result.v_num = itoq( (isdigit( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_isgraph(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISGRAPH);
}
result.v_type = V_NUM;
result.v_num = itoq( (isgraph( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_isprint(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISPRINT);
}
result.v_type = V_NUM;
result.v_num = itoq( (isprint( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_ispunct(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISPUNCT);
}
result.v_type = V_NUM;
result.v_num = itoq( (ispunct( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_isspace(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISSPACE);
}
result.v_type = V_NUM;
result.v_num = itoq( (isspace( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_isxdigit(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISXDIGIT);
}
result.v_type = V_NUM;
result.v_num = itoq( (isxdigit( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_protect(int count, VALUE **vals)
{
int i, depth;
VALUE *v1, *v2, *v3;
VALUE result;
bool have_nblock;
/* initialize VALUE */
result.v_type = V_NULL;
result.v_subtype = V_NOSUBTYPE;
v1 = vals[0];
have_nblock = (v1->v_type == V_NBLOCK);
if (!have_nblock) {
if (v1->v_type != V_ADDR)
return error_value(E_PROTECT_1);
v1 = v1->v_addr;
}
if (count == 1) {
result.v_type = V_NUM;
if (have_nblock)
result.v_num = itoq(v1->v_nblock->subtype);
else
result.v_num = itoq(v1->v_subtype);
return result;
}
v2 = vals[1];
if (v2->v_type == V_ADDR)
v2 = v2->v_addr;
if (v2->v_type != V_NUM||qisfrac(v2->v_num)||zge16b(v2->v_num->num))
return error_value(E_PROTECT_2);
i = qtoi(v2->v_num);
depth = 0;
if (count > 2) {
v3 = vals[2];
if (v3->v_type == V_ADDR)
v3 = v3->v_addr;
if (v3->v_type != V_NUM || qisfrac(v3->v_num) ||
qisneg(v3->v_num) || zge31b(v3->v_num->num))
return error_value(E_PROTECT_3);
depth = qtoi(v3->v_num);
}
protecttodepth(v1, i, depth);
return result;
}
S_FUNC VALUE
f_size(VALUE *vp)
{
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* return information about the number of elements
*
* This is not the sizeof, see f_sizeof() for that information.
* This is not the memsize, see f_memsize() for that information.
*
* The size of a file is treated in a special way ... we do
* not use the number of elements, but rather the length
* of the file as would be reported by fsize().
*/
if (vp->v_type == V_FILE) {
return f_fsize(vp);
} else {
result.v_type = V_NUM;
result.v_num = itoq(elm_count(vp));
}
return result;
}
S_FUNC VALUE
f_sizeof(VALUE *vp)
{
VALUE result;
/* initialize VALUE */
result.v_type = V_NUM;
result.v_subtype = V_NOSUBTYPE;
/*
* return information about memory footprint
*
* This is not the number of elements, see f_size() for that info.
* This is not the memsize, see f_memsize() for that information.
*/
result.v_num = itoq(lsizeof(vp));
return result;
}
S_FUNC VALUE
f_memsize(VALUE *vp)
{
VALUE result;
/* initialize VALUE */
result.v_type = V_NUM;
result.v_subtype = V_NOSUBTYPE;
/*
* return information about memory footprint
*
* This is not the number of elements, see f_size() for that info.
* This is not the sizeof, see f_sizeof() for that information.
*/
result.v_num = itoq(memsize(vp));
return result;
}
S_FUNC VALUE
f_search(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3, *v4;
NUMBER *start, *end;
VALUE vsize;
NUMBER *size;
ZVALUE pos;
ZVALUE indx;
long len;
ZVALUE zlen, tmp;
VALUE result;
long l_start = 0, l_end = 0;
int i = 0;
/* initialize VALUEs */
result.v_subtype = V_NOSUBTYPE;
vsize.v_subtype = V_NOSUBTYPE;
v1 = *vals++;
v2 = *vals++;
if ((v1->v_type == V_FILE || v1->v_type == V_STR) &&
v2->v_type != V_STR)
return error_value(E_SEARCH_2);
start = end = NULL;
if (count > 2) {
v3 = *vals++;
if (v3->v_type != V_NUM && v3->v_type != V_NULL)
return error_value(E_SEARCH_3);
if (v3->v_type == V_NUM) {
start = v3->v_num;
if (qisfrac(start))
return error_value(E_SEARCH_3);
}
}
if (count > 3) {
v4 = *vals;
if (v4->v_type != V_NUM && v4->v_type != V_NULL)
return error_value(E_SEARCH_4);
if (v4->v_type == V_NUM) {
end = v4->v_num;
if (qisfrac(end))
return error_value(E_SEARCH_4);
}
}
result.v_type = V_NULL;
vsize = f_size(v1);
if (vsize.v_type != V_NUM)
return error_value(E_SEARCH_5);
size = vsize.v_num;
if (start) {
if (qisneg(start)) {
start = qqadd(size, start);
if (qisneg(start)) {
qfree(start);
start = qlink(&_qzero_);
}
} else {
start = qlink(start);
}
}
if (end) {
if (!qispos(end)) {
end = qqadd(size, end);
} else {
if (qrel(end, size) > 0)
end = qlink(size);
else
end = qlink(end);
}
}
if (v1->v_type == V_FILE) {
if (count == 2|| (count == 4 &&
(start == NULL || end == NULL))) {
i = ftellid(v1->v_file, &pos);
if (i < 0) {
qfree(size);
if (start)
qfree(start);
if (end)
qfree(end);
return error_value(E_SEARCH_5);
}
if (count == 2 || (count == 4 && end != NULL)) {
start = qalloc();
start->num = pos;
} else {
end = qalloc();
end->num = pos;
}
}
if (start == NULL)
start = qlink(&_qzero_);
if (end == NULL)
end = size;
else
qfree(size);
len = v2->v_str->s_len;
utoz(len, &zlen);
zsub(end->num, zlen, &tmp);
zfree(zlen);
i = fsearch(v1->v_file, v2->v_str->s_str,
start->num, tmp, &indx);
zfree(tmp);
if (i == 2) {
result.v_type = V_NUM;
result.v_num = start;
qfree(end);
return result;
}
qfree(start);
qfree(end);
if (i == EOF)
return error_value(errno);
if (i < 0)
return error_value(E_SEARCH_6);
if (i == 0) {
result.v_type = V_NUM;
result.v_num = qalloc();
result.v_num->num = indx;
}
return result;
}
if (start == NULL)
start = qlink(&_qzero_);
if (end == NULL)
end = qlink(size);
if (qrel(start, end) >= 0) {
qfree(size);
qfree(start);
qfree(end);
return result;
}
qfree(size);
l_start = ztolong(start->num);
l_end = ztolong(end->num);
switch (v1->v_type) {
case V_MAT:
i = matsearch(v1->v_mat, v2, l_start, l_end, &indx);
break;
case V_LIST:
i = listsearch(v1->v_list, v2, l_start, l_end, &indx);
break;
case V_ASSOC:
i = assocsearch(v1->v_assoc, v2, l_start, l_end, &indx);
break;
case V_STR:
i = stringsearch(v1->v_str, v2->v_str, l_start, l_end,
&indx);
break;
default:
qfree(start);
qfree(end);
return error_value(E_SEARCH_1);
}
qfree(start);
qfree(end);
if (i == 0) {
result.v_type = V_NUM;
result.v_num = qalloc();
result.v_num->num = indx;
}
return result;
}
S_FUNC VALUE
f_rsearch(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3, *v4;
NUMBER *start, *end;
VALUE vsize;
NUMBER *size;
NUMBER *qlen;
NUMBER *qtmp;
ZVALUE pos;
ZVALUE indx;
VALUE result;
long l_start = 0, l_end = 0;
int i;
/* initialize VALUEs */
vsize.v_subtype = V_NOSUBTYPE;
result.v_subtype = V_NOSUBTYPE;
v1 = *vals++;
v2 = *vals++;
if ((v1->v_type == V_FILE || v1->v_type == V_STR) &&
v2->v_type != V_STR)
return error_value(E_RSEARCH_2);
start = end = NULL;
if (count > 2) {
v3 = *vals++;
if (v3->v_type != V_NUM && v3->v_type != V_NULL)
return error_value(E_RSEARCH_3);
if (v3->v_type == V_NUM) {
start = v3->v_num;
if (qisfrac(start))
return error_value(E_RSEARCH_3);
}
}
if (count > 3) {
v4 = *vals;
if (v4->v_type != V_NUM && v4->v_type != V_NULL)
return error_value(E_RSEARCH_4);
if (v4->v_type == V_NUM) {
end = v4->v_num;
if (qisfrac(end))
return error_value(E_RSEARCH_3);
}
}
result.v_type = V_NULL;
vsize = f_size(v1);
if (vsize.v_type != V_NUM)
return error_value(E_RSEARCH_5);
size = vsize.v_num;
if (start) {
if (qisneg(start)) {
start = qqadd(size, start);
if (qisneg(start)) {
qfree(start);
start = qlink(&_qzero_);
}
}
else
start = qlink(start);
}
if (end) {
if (!qispos(end)) {
end = qqadd(size, end);
} else {
if (qrel(end, size) > 0)
end = qlink(size);
else
end = qlink(end);
}
}
if (v1->v_type == V_FILE) {
if (count == 2 || (count == 4 &&
(start == NULL || end == NULL))) {
i = ftellid(v1->v_file, &pos);
if (i < 0) {
qfree(size);
if (start)
qfree(start);
if (end)
qfree(end);
return error_value(E_RSEARCH_5);
}
if (count == 2 || (count == 4 && end != NULL)) {
start = qalloc();
start->num = pos;
} else {
end = qalloc();
end->num = pos;
}
}
qlen = utoq(v2->v_str->s_len);
qtmp = qsub(size, qlen);
qfree(size);
size = qtmp;
if (count < 4) {
end = start;
start = NULL;
} else {
qtmp = qsub(end, qlen);
qfree(end);
end = qtmp;
}
if (end == NULL)
end = qlink(size);
if (start == NULL)
start = qlink(&_qzero_);
if (qrel(end, size) > 0) {
qfree(end);
end = qlink(size);
}
qfree(qlen);
qfree(size);
if (qrel(start, end) > 0) {
qfree(start);
qfree(end);
return result;
}
i = frsearch(v1->v_file, v2->v_str->s_str,
end->num,start->num, &indx);
qfree(start);
qfree(end);
if (i == EOF)
return error_value(errno);
if (i < 0)
return error_value(E_RSEARCH_6);
if (i == 0) {
result.v_type = V_NUM;
result.v_num = qalloc();
result.v_num->num = indx;
}
return result;
}
if (count < 4) {
if (start) {
end = qinc(start);
qfree(start);
}
else
end = qlink(size);
start = qlink(&_qzero_);
} else {
if (start == NULL)
start = qlink(&_qzero_);
if (end == NULL)
end = qlink(size);
}
qfree(size);
if (qrel(start, end) >= 0) {
qfree(start);
qfree(end);
return result;
}
l_start = ztolong(start->num);
l_end = ztolong(end->num);
switch (v1->v_type) {
case V_MAT:
i = matrsearch(v1->v_mat, v2, l_start, l_end, &indx);
break;
case V_LIST:
i = listrsearch(v1->v_list, v2, l_start, l_end, &indx);
break;
case V_ASSOC:
i = assocrsearch(v1->v_assoc, v2, l_start,
l_end, &indx);
break;
case V_STR:
i = stringrsearch(v1->v_str, v2->v_str, l_start,
l_end, &indx);
break;
default:
qfree(start);
qfree(end);
return error_value(E_RSEARCH_1);
}
qfree(start);
qfree(end);
if (i == 0) {
result.v_type = V_NUM;
result.v_num = qalloc();
result.v_num->num = indx;
}
return result;
}
S_FUNC VALUE
f_list(int count, VALUE **vals)
{
VALUE result;
/* initialize VALUE */
result.v_type = V_LIST;
result.v_subtype = V_NOSUBTYPE;
result.v_list = listalloc();
while (count-- > 0)
insertlistlast(result.v_list, *vals++);
return result;
}
/*ARGSUSED*/
S_FUNC VALUE
f_assoc(int UNUSED(count), VALUE **UNUSED(vals))
{
VALUE result;
/* initialize VALUE */
result.v_type = V_ASSOC;
result.v_subtype = V_NOSUBTYPE;
result.v_assoc = assocalloc(0L);
return result;
}
S_FUNC VALUE
f_indices(VALUE *v1, VALUE *v2)
{
VALUE result;
LIST *lp;
if (v2->v_type != V_NUM || zge31b(v2->v_num->num))
return error_value(E_INDICES_2);
switch (v1->v_type) {
case V_ASSOC:
lp = associndices(v1->v_assoc, qtoi(v2->v_num));
break;
case V_MAT:
lp = matindices(v1->v_mat, qtoi(v2->v_num));
break;
default:
return error_value(E_INDICES_1);
}
result.v_type = V_NULL;
result.v_subtype = V_NOSUBTYPE;
if (lp) {
result.v_type = V_LIST;
result.v_list = lp;
}
return result;
}
S_FUNC VALUE
f_listinsert(int count, VALUE **vals)
{
VALUE *v1, *v2, *v3;
VALUE result;
long pos;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
v1 = *vals++;
if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
return error_value(E_INSERT_1);
if (v1->v_addr->v_subtype & V_NOREALLOC)
return error_value(E_LIST_1);
v2 = *vals++;
if (v2->v_type == V_ADDR)
v2 = v2->v_addr;
if ((v2->v_type != V_NUM) || qisfrac(v2->v_num))
return error_value(E_INSERT_2);
pos = qtoi(v2->v_num);
count--;
while (--count > 0) {
v3 = *vals++;
if (v3->v_type == V_ADDR)
v3 = v3->v_addr;
insertlistmiddle(v1->v_addr->v_list, pos++, v3);
}
result.v_type = V_NULL;
return result;
}
S_FUNC VALUE
f_listpush(int count, VALUE **vals)
{
VALUE result;
VALUE *v1, *v2;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
v1 = *vals++;
if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
return error_value(E_PUSH);
if (v1->v_addr->v_subtype & V_NOREALLOC)
return error_value(E_LIST_3);
while (--count > 0) {
v2 = *vals++;
if (v2->v_type == V_ADDR)
v2 = v2->v_addr;
insertlistfirst(v1->v_addr->v_list, v2);
}
result.v_type = V_NULL;
return result;
}
S_FUNC VALUE
f_listappend(int count, VALUE **vals)
{
VALUE *v1, *v2;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
v1 = *vals++;
if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
return error_value(E_APPEND);
if (v1->v_addr->v_subtype & V_NOREALLOC)
return error_value(E_LIST_4);
while (--count > 0) {
v2 = *vals++;
if (v2->v_type == V_ADDR)
v2 = v2->v_addr;
insertlistlast(v1->v_addr->v_list, v2);
}
result.v_type = V_NULL;
return result;
}
S_FUNC VALUE
f_listdelete(VALUE *v1, VALUE *v2)
{
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
return error_value(E_DELETE_1);
if (v1->v_addr->v_subtype & V_NOREALLOC)
return error_value(E_LIST_2);
if (v2->v_type == V_ADDR)
v2 = v2->v_addr;
if ((v2->v_type != V_NUM) || qisfrac(v2->v_num))
return error_value(E_DELETE_2);
removelistmiddle(v1->v_addr->v_list, qtoi(v2->v_num), &result);
return result;
}
S_FUNC VALUE
f_listpop(VALUE *vp)
{
VALUE result;
if ((vp->v_type != V_ADDR) || (vp->v_addr->v_type != V_LIST))
return error_value(E_POP);
if (vp->v_addr->v_subtype & V_NOREALLOC)
return error_value(E_LIST_5);
removelistfirst(vp->v_addr->v_list, &result);
return result;
}
S_FUNC VALUE
f_listremove(VALUE *vp)
{
VALUE result;
if ((vp->v_type != V_ADDR) || (vp->v_addr->v_type != V_LIST))
return error_value(E_REMOVE);
if (vp->v_addr->v_subtype & V_NOREALLOC)
return error_value(E_LIST_6);
removelistlast(vp->v_addr->v_list, &result);
return result;
}
/*
* Return the current user time of calc in seconds.
*/
S_FUNC NUMBER *
f_usertime(void)
{
#if defined(HAVE_GETRUSAGE)
struct rusage usage; /* system resource usage */
int who = RUSAGE_SELF; /* obtain time for just this process */
int status; /* getrusage() return code */
NUMBER *ret; /* CPU time to return */
NUMBER *secret; /* whole seconds of CPU time to return */
NUMBER *usecret; /* microseconds of CPU time to return */
/* get the resource information for ourself */
status = getrusage(who, &usage);
if (status < 0) {
/* system call error, so return 0 */
return qlink(&_qzero_);
}
/* add user time */
secret = stoq(usage.ru_utime.tv_sec);
usecret = iitoq((long)usage.ru_utime.tv_usec, 1000000L);
ret = qqadd(secret, usecret);
qfree(secret);
qfree(usecret);
/* return user CPU time */
return ret;
#else /* HAVE_GETRUSAGE */
/* not a POSIX system */
return qlink(&_qzero_);
#endif /* HAVE_GETRUSAGE */
}
/*
* Return the current kernel time of calc in seconds.
* This is the kernel mode time only.
*/
S_FUNC NUMBER *
f_systime(void)
{
#if defined(HAVE_GETRUSAGE)
struct rusage usage; /* system resource usage */
int who = RUSAGE_SELF; /* obtain time for just this process */
int status; /* getrusage() return code */
NUMBER *ret; /* CPU time to return */
NUMBER *secret; /* whole seconds of CPU time to return */
NUMBER *usecret; /* microseconds of CPU time to return */
/* get the resource information for ourself */
status = getrusage(who, &usage);
if (status < 0) {
/* system call error, so return 0 */
return qlink(&_qzero_);
}
/* add kernel time */
secret = stoq(usage.ru_stime.tv_sec);
usecret = iitoq((long)usage.ru_stime.tv_usec, 1000000L);
ret = qqadd(secret, usecret);
qfree(secret);
qfree(usecret);
/* return kernel CPU time */
return ret;
#else /* HAVE_GETRUSAGE */
/* not a POSIX system */
return qlink(&_qzero_);
#endif /* HAVE_GETRUSAGE */
}
/*
* Return the current user and kernel time of calc in seconds.
*/
S_FUNC NUMBER *
f_runtime(void)
{
#if defined(HAVE_GETRUSAGE)
struct rusage usage; /* system resource usage */
int who = RUSAGE_SELF; /* obtain time for just this process */
int status; /* getrusage() return code */
NUMBER *user; /* user CPU time to return */
NUMBER *sys; /* kernel CPU time to return */
NUMBER *ret; /* total CPU time to return */
NUMBER *secret; /* whole seconds of CPU time to return */
NUMBER *usecret; /* microseconds of CPU time to return */
/* get the resource information for ourself */
status = getrusage(who, &usage);
if (status < 0) {
/* system call error, so return 0 */
return qlink(&_qzero_);
}
/* add kernel time */
secret = stoq(usage.ru_stime.tv_sec);
usecret = iitoq((long)usage.ru_stime.tv_usec, 1000000L);
sys = qqadd(secret, usecret);
qfree(secret);
qfree(usecret);
/* add user time */
secret = stoq(usage.ru_utime.tv_sec);
usecret = iitoq((long)usage.ru_utime.tv_usec, 1000000L);
user = qqadd(secret, usecret);
qfree(secret);
qfree(usecret);
/* total time is user + kernel */
ret = qqadd(user, sys);
qfree(user);
qfree(sys);
/* return CPU time */
return ret;
#else /* HAVE_GETRUSAGE */
/* not a POSIX system */
return qlink(&_qzero_);
#endif /* HAVE_GETRUSAGE */
}
/*
* return the number of second since the Epoch (00:00:00 1 Jan 1970 UTC).
*/
S_FUNC NUMBER *
f_time(void)
{
return itoq((long) time(0));
}
/*
* time in asctime()/ctime() format
*/
S_FUNC VALUE
f_ctime(void)
{
VALUE res;
time_t now; /* the current time */
/* initialize VALUE */
res.v_subtype = V_NOSUBTYPE;
res.v_type = V_STR;
/* get the time */
now = time(NULL);
res.v_str = makenewstring(ctime(&now));
return res;
}
S_FUNC VALUE
f_fopen(VALUE *v1, VALUE *v2)
{
VALUE result;
FILEID id;
char *mode;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/* check for a valid mode [rwa][b+\0][b+\0] */
if (v1->v_type != V_STR || v2->v_type != V_STR)
return error_value(E_FOPEN_1);
mode = v2->v_str->s_str;
if ((*mode != 'r') && (*mode != 'w') && (*mode != 'a'))
return error_value(E_FOPEN_2);
if (mode[1] != '\0') {
if (mode[1] != '+' && mode[1] != 'b')
return error_value(E_FOPEN_2);
if (mode[2] != '\0') {
if ((mode[2] != '+' && mode[2] != 'b') ||
mode[1] == mode[2])
return error_value(E_FOPEN_2);
if (mode[3] != '\0')
return error_value(E_FOPEN_2);
}
}
/* try to open */
errno = 0;
id = openid(v1->v_str->s_str, v2->v_str->s_str);
if (id == FILEID_NONE)
return error_value(errno);
if (id < 0)
return error_value(-id);
result.v_type = V_FILE;
result.v_file = id;
return result;
}
S_FUNC VALUE
f_fpathopen(int count, VALUE **vals)
{
VALUE result;
FILEID id;
char *mode;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/* check for valid strong */
if (vals[0]->v_type != V_STR || vals[1]->v_type != V_STR) {
return error_value(E_FPATHOPEN_1);
}
if (count == 3 && vals[2]->v_type != V_STR) {
return error_value(E_FPATHOPEN_1);
}
/* check for a valid mode [rwa][b+\0][b+\0] */
mode = vals[1]->v_str->s_str;
if ((*mode != 'r') && (*mode != 'w') && (*mode != 'a'))
return error_value(E_FPATHOPEN_2);
if (mode[1] != '\0') {
if (mode[1] != '+' && mode[1] != 'b')
return error_value(E_FPATHOPEN_2);
if (mode[2] != '\0') {
if ((mode[2] != '+' && mode[2] != 'b') ||
mode[1] == mode[2])
return error_value(E_FPATHOPEN_2);
if (mode[3] != '\0')
return error_value(E_FPATHOPEN_2);
}
}
/* try to open along a path */
errno = 0;
if (count == 2) {
id = openpathid(vals[0]->v_str->s_str,
vals[1]->v_str->s_str,
calcpath);
} else {
id = openpathid(vals[0]->v_str->s_str,
vals[1]->v_str->s_str,
vals[2]->v_str->s_str);
}
if (id == FILEID_NONE)
return error_value(errno);
if (id < 0)
return error_value(-id);
result.v_type = V_FILE;
result.v_file = id;
return result;
}
S_FUNC VALUE
f_freopen(int count, VALUE **vals)
{
VALUE result;
FILEID id;
char *mode;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/* check for a valid mode [rwa][b+\0][b+\0] */
if (vals[0]->v_type != V_FILE)
return error_value(E_FREOPEN_1);
if (vals[1]->v_type != V_STR)
return error_value(E_FREOPEN_2);
mode = vals[1]->v_str->s_str;
if ((*mode != 'r') && (*mode != 'w') && (*mode != 'a'))
return error_value(E_FREOPEN_2);
if (mode[1] != '\0') {
if (mode[1] != '+' && mode[1] != 'b')
return error_value(E_FREOPEN_2);
if (mode[2] != '\0') {
if ((mode[2] != '+' && mode[2] != 'b') ||
mode[1] == mode[2])
return error_value(E_FOPEN_2);
if (mode[3] != '\0')
return error_value(E_FREOPEN_2);
}
}
/* try to reopen */
errno = 0;
if (count == 2) {
id = reopenid(vals[0]->v_file, mode, NULL);
} else {
if (vals[2]->v_type != V_STR)
return error_value(E_FREOPEN_3);
id = reopenid(vals[0]->v_file, mode,
vals[2]->v_str->s_str);
}
if (id == FILEID_NONE)
return error_value(errno);
result.v_type = V_NULL;
return result;
}
S_FUNC VALUE
f_fclose(int count, VALUE **vals)
{
VALUE result;
VALUE *vp;
int n, i=0;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
errno = 0;
if (count == 0) {
i = closeall();
} else {
for (n = 0; n < count; n++) {
vp = vals[n];
if (vp->v_type != V_FILE)
return error_value(E_FCLOSE_1);
}
for (n = 0; n < count; n++) {
vp = vals[n];
i = closeid(vp->v_file);
if (i < 0)
return error_value(E_REWIND_2);
}
}
if (i < 0)
return error_value(errno);
result.v_type = V_NULL;
return result;
}
S_FUNC VALUE
f_rm(int count, VALUE **vals)
{
VALUE result;
int force; /* true -> -f was given as 1st arg */
int i;
int j;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* firewall
*/
if (!allow_write)
return error_value(E_WRPERM);
/*
* check on each arg
*/
for (i=0; i < count; ++i) {
if (vals[i]->v_type != V_STR)
return error_value(E_RM_1);
if (vals[i]->v_str->s_str[0] == '\0')
return error_value(E_RM_1);
}
/*
* look for a leading -f option
*/
force = (strcmp(vals[0]->v_str->s_str, "-f") == 0);
if (force) {
--count;
++vals;
}
/*
* remove file(s)
*/
for (i=0; i < count; ++i) {
j = remove(vals[i]->v_str->s_str);
if (!force && j < 0)
return error_value(errno);
}
result.v_type = V_NULL;
result.v_subtype = V_NOSUBTYPE;
return result;
}
S_FUNC VALUE
f_error(int count, VALUE **vals)
{
VALUE *vp;
long r;
/*
* case: error() no args
*/
if (count == 0) {
/* fetch but do NOT set errno */
r = set_errno(NULL_ERRNUM);
/*
* case: 1 arg
*/
} else {
vp = vals[0]; /* get 1st arg */
/*
* case: negative or 0 v_type
*/
if (vp->v_type <= 0) {
r = (long) -vp->v_type;
if (is_valid_errnum(r) == false) {
error_value(E_ERROR_2);
math_error("Numeric argument is outside valid errnum range for error");
not_reached();
}
/*
* case: error(errnum | "E_STRING") arg
*/
} else {
switch (vp->v_type) {
/*
* case: error("E_STRING")
*/
case V_STR:
r = errsym_2_errnum(vp->v_str->s_str);
if (is_valid_errnum(r) == false) {
error_value(E_ERROR_3);
math_error("String argument is not a valid E_STRING for error");
not_reached();
}
break;
/*
* case: error(errnum)
*/
case V_NUM:
r = qtoi(vp->v_num);
if (is_valid_errnum(r) == false) {
error_value(E_ERROR_2);
math_error("Numeric argument is outside valid errnum range for error");
not_reached();
}
break;
/*
* case: invalid type
*/
default:
error_value(E_ERROR_1);
math_error("Invalid argument type for error");
not_reached();
}
}
}
/*
* return error
*/
return error_value(r);
}
S_FUNC VALUE
f_errno(int count, VALUE **vals)
{
int olderr; /* previous errno value */
int newerr = NULL_ERRNUM; /* new errno to set */
VALUE *vp; /* arg[1] */
VALUE result; /* errno as a VALUE */
/* initialize VALUE */
result.v_type = V_NUM;
result.v_subtype = V_NOSUBTYPE;
/*
* case: errno() no args
*/
if (count == 0) {
/* fetch but do NOT set errno */
olderr = set_errno(NULL_ERRNUM);
/*
* case: 1 arg
*/
} else {
vp = vals[0]; /* get 1st arg */
/*
* case: negative or 0 v_type
*/
if (vp->v_type <= 0) {
newerr = (int) -vp->v_type;
if (is_valid_errnum(newerr) == false) {
error_value(E_ERRNO_2);
math_error("Numeric argument is outside valid errnum range for errno");
not_reached();
}
/*
* case: errno(errnum | "E_STRING") arg
*/
} else {
switch (vp->v_type) {
/*
* case: errno("E_STRING")
*/
case V_STR:
newerr = errsym_2_errnum(vp->v_str->s_str);
if (is_valid_errnum(newerr) == false) {
error_value(E_ERRNO_3);
math_error("String argument is not a valid E_STRING for errno");
not_reached();
}
break;
/*
* case: errno(errnum)
*/
case V_NUM:
newerr = qtoi(vp->v_num);
if (is_valid_errnum(newerr) == false) {
error_value(E_ERRNO_2);
math_error("Numeric argument is outside valid errnum range for errno");
not_reached();
}
break;
/*
* case: invalid type
*/
default:
error_value(E_ERRNO_1);
math_error("Invalid argument type for errno");
not_reached();
}
}
}
/*
* return errno
*/
olderr = set_errno(newerr);
result.v_num = itoq((long) olderr);
return result;
}
S_FUNC VALUE
f_strerror(int count, VALUE **vals)
{
int errnum = NULL_ERRNUM; /* errnum to convert */
char *errmsg; /* errnum converted into errmsg string, or NULL */
bool alloced = false; /* true ==> errmsg was allocated, false ==> errmsg is static */
VALUE *vp; /* arg[1] */
VALUE result; /* errmsg string as a VALUE */
/* initialize VALUE */
result.v_type = V_STR;
result.v_subtype = V_NOSUBTYPE;
/*
* case: strerror() no args
*/
if (count == 0) {
/* fetch but do NOT set errno */
errnum = set_errno(NULL_ERRNUM);
/*
* case: 1 arg
*/
} else {
vp = vals[0]; /* get 1st arg */
/*
* case: negative or 0 v_type
*/
if (vp->v_type <= 0) {
errnum = (int) -vp->v_type;
if (is_valid_errnum(errnum) == false) {
error_value(E_STRERROR_2);
math_error("Numeric argument is outside valid errnum range for strerror");
not_reached();
}
/*
* case: strerror(errnum | "E_STRING") arg
*/
} else {
switch (vp->v_type) {
/*
* case: strerror("E_STRING")
*/
case V_STR:
errnum = errsym_2_errnum(vp->v_str->s_str);
if (is_valid_errnum(errnum) == false) {
error_value(E_STRERROR_3);
math_error("String argument is not a valid E_STRING for strerror");
not_reached();
}
break;
/*
* case: strerror(errnum)
*/
case V_NUM:
errnum = qtoi(vp->v_num);
if (is_valid_errnum(errnum) == false) {
error_value(E_STRERROR_2);
math_error("Numeric argument is outside valid errnum range for strerror");
not_reached();
}
break;
/*
* case: invalid type
*/
default:
error_value(E_STRERROR_1);
math_error("Invalid argument type for strerror");
not_reached();
}
}
}
/*
* convert errnum into errmsg string
*/
errmsg = errnum_2_errmsg(errnum, &alloced);
if (errmsg == NULL) {
/* this should not happen: but in case it does we will throw an error */
error_value(E_STRERROR_4);
math_error("errnum_2_errmsg returned NULL as called from strerror");
not_reached();
}
result.v_str = makenewstring(errmsg);
/*
* free errmsg is it was allocated
*/
if (alloced == true) {
free(errmsg);
alloced = false;
errmsg = NULL;
}
/*
* return errmsg result as a V_STR
*/
return result;
}
S_FUNC VALUE
f_errcount(int count, VALUE **vals)
{
int newcount, oldcount;
VALUE *vp;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
newcount = -1;
if (count > 0) {
vp = vals[0];
/* arg must be an integer */
if (vp->v_type != V_NUM || qisfrac(vp->v_num) ||
qisneg(vp->v_num) || zge31b(vp->v_num->num)) {
math_error("errcount argument out of range");
not_reached();
}
newcount = (int) ztoi(vp->v_num->num);
}
oldcount = set_errcount(newcount);
result.v_type = V_NUM;
result.v_num = itoq((long) oldcount);
return result;
}
S_FUNC VALUE
f_errmax(int count, VALUE **vals)
{
long oldmax;
VALUE *vp;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
oldmax = errmax;
if (count > 0) {
vp = vals[0];
if (vp->v_type != V_NUM || qisfrac(vp->v_num) ||
zge31b(vp->v_num->num) || zltnegone(vp->v_num->num)) {
fprintf(stderr,
"Out-of-range arg for errmax ignored\n");
} else {
errmax = ztoi(vp->v_num->num);
}
}
result.v_type = V_NUM;
result.v_num = itoq((long) oldmax);
return result;
}
S_FUNC VALUE
f_stoponerror(int count, VALUE **vals)
{
long oldval;
VALUE *vp;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
oldval = stoponerror;
if (count > 0) {
vp = vals[0];
if (vp->v_type != V_NUM || qisfrac(vp->v_num) ||
zge31b(vp->v_num->num) || zltnegone(vp->v_num->num)) {
fprintf(stderr,
"Out-of-range arg for stoponerror ignored\n");
} else {
stoponerror = ztoi(vp->v_num->num);
}
}
result.v_type = V_NUM;
result.v_num = itoq((long) oldval);
return result;
}
S_FUNC VALUE
f_iserror(VALUE *vp)
{
VALUE res;
/* initialize VALUE */
res.v_subtype = V_NOSUBTYPE;
res.v_type = V_NUM;
res.v_num = itoq((long)((vp->v_type < 0) ? - vp->v_type : 0));
return res;
}
S_FUNC VALUE
f_newerror(int count, VALUE **vals)
{
char *str;
int index;
int errnum;
str = NULL;
if (count > 0 && vals[0]->v_type == V_STR)
str = vals[0]->v_str->s_str;
if (str == NULL || str[0] == '\0')
str = "???";
if (nexterrnum == E__USERDEF)
initstr(&newerrorstr);
index = findstr(&newerrorstr, str);
if (index >= 0) {
errnum = E__USERDEF + index;
} else {
if (nexterrnum == E__USERMAX)
math_error("Too many new error values");
errnum = nexterrnum++;
addstr(&newerrorstr, str);
}
return error_value(errnum);
}
S_FUNC VALUE
f_ferror(VALUE *vp)
{
VALUE result;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_FILE)
return error_value(E_FERROR_1);
i = errorid(vp->v_file);
if (i < 0)
return error_value(E_FERROR_2);
result.v_type = V_NUM;
result.v_num = itoq((long) i);
return result;
}
S_FUNC VALUE
f_feof(VALUE *vp)
{
VALUE result;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_FILE)
return error_value(E_FEOF_1);
i = eofid(vp->v_file);
if (i < 0)
return error_value(E_FEOF_2);
result.v_type = V_NUM;
result.v_num = itoq((long) i);
return result;
}
S_FUNC VALUE
f_fflush(int count, VALUE **vals)
{
VALUE result;
int i, n;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
i = 0;
errno = 0;
if (count == 0) {
#if !defined(_WIN32) && !defined(_WIN64)
i = flushall();
#endif /* Windows free systems */
} else {
for (n = 0; n < count; n++) {
if (vals[n]->v_type != V_FILE)
return error_value(E_FFLUSH);
}
for (n = 0; n < count; n++) {
i |= flushid(vals[n]->v_file);
}
}
if (i == EOF)
return error_value(errno);
result.v_type = V_NULL;
return result;
}
S_FUNC VALUE
f_fsize(VALUE *vp)
{
VALUE result;
ZVALUE len; /* file length */
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_FILE)
return error_value(E_FSIZE_1);
i = getsize(vp->v_file, &len);
if (i == EOF)
return error_value(errno);
if (i)
return error_value(E_FSIZE_2);
result.v_type = V_NUM;
result.v_num = qalloc();
result.v_num->num = len;
return result;
}
S_FUNC VALUE
f_fseek(int count, VALUE **vals)
{
VALUE result;
int whence;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/* firewalls */
errno = 0;
if (vals[0]->v_type != V_FILE)
return error_value(E_FSEEK_1);
if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num))
return error_value(E_FSEEK_2);
if (count == 2) {
whence = 0;
} else {
if (vals[2]->v_type != V_NUM || qisfrac(vals[2]->v_num) ||
qisneg(vals[2]->v_num))
return error_value(E_FSEEK_2);
if (vals[2]->v_num->num.len > 1)
return error_value (E_FSEEK_2);
whence = (int)(unsigned int)(vals[2]->v_num->num.v[0]);
if (whence > 2)
return error_value (E_FSEEK_2);
}
i = fseekid(vals[0]->v_file, vals[1]->v_num->num, whence);
result.v_type = V_NULL;
if (i == EOF)
return error_value(errno);
if (i < 0)
return error_value(E_FSEEK_3);
return result;
}
S_FUNC VALUE
f_ftell(VALUE *vp)
{
VALUE result;
ZVALUE pos; /* current file position */
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
errno = 0;
if (vp->v_type != V_FILE)
return error_value(E_FTELL_1);
i = ftellid(vp->v_file, &pos);
if (i < 0)
return error_value(E_FTELL_2);
result.v_type = V_NUM;
result.v_num = qalloc();
result.v_num->num = pos;
return result;
}
S_FUNC VALUE
f_rewind(int count, VALUE **vals)
{
VALUE result;
int n;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (count == 0) {
rewindall();
} else {
for (n = 0; n < count; n++) {
if (vals[n]->v_type != V_FILE)
return error_value(E_REWIND_1);
}
for (n = 0; n < count; n++) {
if (rewindid(vals[n]->v_file) != 0) {
return error_value(E_REWIND_2);
}
}
}
result.v_type = V_NULL;
return result;
}
S_FUNC VALUE
f_fprintf(int count, VALUE **vals)
{
VALUE result;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vals[0]->v_type != V_FILE)
return error_value(E_FPRINTF_1);
if (vals[1]->v_type != V_STR)
return error_value(E_FPRINTF_2);
i = idprintf(vals[0]->v_file, vals[1]->v_str->s_str,
count - 2, vals + 2);
if (i > 0)
return error_value(E_FPRINTF_3);
result.v_type = V_NULL;
return result;
}
S_FUNC int
strscan(char *s, int count, VALUE **vals)
{
char ch, chtmp;
char *s0;
int n = 0;
VALUE val, result;
VALUE *var;
/* initialize VALUEs */
val.v_subtype = V_NOSUBTYPE;
result.v_subtype = V_NOSUBTYPE;
val.v_type = V_STR;
while (*s != '\0') {
s--;
while ((ch = *++s)) {
if (!isspace((int)ch))
break;
}
if (ch == '\0' || count-- == 0)
return n;
s0 = s;
while ((ch = *++s)) {
if (isspace((int)ch))
break;
}
chtmp = ch;
*s = '\0';
n++;
val.v_str = makenewstring(s0);
result = f_eval(&val);
var = *vals++;
if (var->v_type == V_ADDR) {
var = var->v_addr;
freevalue(var);
*var = result;
}
*s = chtmp;
}
return n;
}
S_FUNC int
filescan(FILEID id, int count, VALUE **vals)
{
STRING *str;
int i;
int n = 0;
VALUE val;
VALUE result;
VALUE *var;
/* initialize VALUEs */
val.v_type = V_STR;
val.v_subtype = V_NOSUBTYPE;
result.v_subtype = V_NOSUBTYPE;
while (count-- > 0) {
i = readid(id, 6, &str);
if (i == EOF)
break;
if (i > 0)
return EOF;
n++;
val.v_str = str;
result = f_eval(&val);
var = *vals++;
if (var->v_type == V_ADDR) {
var = var->v_addr;
freevalue(var);
*var = result;
}
}
return n;
}
S_FUNC VALUE
f_scan(int count, VALUE **vals)
{
char *cp;
VALUE result;
int i;
/* initialize VALUEs */
result.v_subtype = V_NOSUBTYPE;
cp = nextline();
if (cp == NULL) {
result.v_type = V_NULL;
return result;
}
i = strscan(cp, count, vals);
result.v_type = V_NUM;
result.v_num = itoq((long) i);
return result;
}
S_FUNC VALUE
f_strscan(int count, VALUE **vals)
{
VALUE *vp;
VALUE result;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
vp = *vals;
if (vp->v_type == V_ADDR)
vp = vp->v_addr;
if (vp->v_type != V_STR)
return error_value(E_STRSCAN);
i = strscan(vp->v_str->s_str, count - 1, vals + 1);
result.v_type = V_NUM;
result.v_num = itoq((long) i);
return result;
}
S_FUNC VALUE
f_fscan(int count, VALUE **vals)
{
VALUE *vp;
VALUE result;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
errno = 0;
vp = *vals;
if (vp->v_type == V_ADDR)
vp = vp->v_addr;
if (vp->v_type != V_FILE)
return error_value(E_FSCAN_1);
i = filescan(vp->v_file, count - 1, vals + 1);
if (i == EOF)
return error_value(errno);
if (i < 0)
return error_value(E_FSCAN_2);
result.v_type = V_NUM;
result.v_num = itoq((long) i);
return result;
}
S_FUNC VALUE
f_scanf(int count, VALUE **vals)
{
VALUE *vp;
VALUE result;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
vp = *vals;
if (vp->v_type == V_ADDR)
vp = vp->v_addr;
if (vp->v_type != V_STR)
return error_value(E_SCANF_1);
for (i = 1; i < count; i++) {
if (vals[i]->v_type != V_ADDR)
return error_value(E_SCANF_2);
}
i = fscanfid(FILEID_STDIN, vp->v_str->s_str, count - 1, vals + 1);
if (i < 0)
return error_value(E_SCANF_3);
result.v_type = V_NUM;
result.v_num = itoq((long) i);
return result;
}
S_FUNC VALUE
f_strscanf(int count, VALUE **vals)
{
VALUE *vp, *vq;
VALUE result;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
errno = 0;
vp = vals[0];
if (vp->v_type == V_ADDR)
vp = vp->v_addr;
if (vp->v_type != V_STR)
return error_value(E_STRSCANF_1);
vq = vals[1];
if (vq->v_type == V_ADDR)
vq = vq->v_addr;
if (vq->v_type != V_STR)
return error_value(E_STRSCANF_2);
for (i = 2; i < count; i++) {
if (vals[i]->v_type != V_ADDR)
return error_value(E_STRSCANF_3);
}
i = scanfstr(vp->v_str->s_str, vq->v_str->s_str,
count - 2, vals + 2);
if (i == EOF)
return error_value(errno);
if (i < 0)
return error_value(E_STRSCANF_4);
result.v_type = V_NUM;
result.v_num = itoq((long) i);
return result;
}
S_FUNC VALUE
f_fscanf(int count, VALUE **vals)
{
VALUE *vp, *sp;
VALUE result;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
vp = *vals++;
if (vp->v_type == V_ADDR)
vp = vp->v_addr;
if (vp->v_type != V_FILE)
return error_value(E_FSCANF_1);
sp = *vals++;
if (sp->v_type == V_ADDR)
sp = sp->v_addr;
if (sp->v_type != V_STR)
return error_value(E_FSCANF_2);
for (i = 0; i < count - 2; i++) {
if (vals[i]->v_type != V_ADDR)
return error_value(E_FSCANF_3);
}
i = fscanfid(vp->v_file, sp->v_str->s_str, count - 2, vals);
if (i == EOF) {
result.v_type = V_NULL;
return result;
}
if (i < 0)
return error_value(E_FSCANF_4);
result.v_type = V_NUM;
result.v_num = itoq((long) i);
return result;
}
S_FUNC VALUE
f_fputc(VALUE *v1, VALUE *v2)
{
VALUE result;
NUMBER *q;
int ch;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (v1->v_type != V_FILE)
return error_value(E_FPUTC_1);
switch (v2->v_type) {
case V_STR:
ch = v2->v_str->s_str[0];
break;
case V_NUM:
q = v2->v_num;
if (!qisint(q))
return error_value(E_FPUTC_2);
ch = qisneg(q) ? (int)(-q->num.v[0] & 0xff) :
(int)(q->num.v[0] & 0xff);
break;
case V_NULL:
ch = 0;
break;
default:
return error_value(E_FPUTC_2);
}
i = idfputc(v1->v_file, ch);
if (i > 0)
return error_value(E_FPUTC_3);
result.v_type = V_NULL;
return result;
}
S_FUNC VALUE
f_fputs(int count, VALUE **vals)
{
VALUE result;
int i, err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vals[0]->v_type != V_FILE)
return error_value(E_FPUTS_1);
for (i = 1; i < count; i++) {
if (vals[i]->v_type != V_STR)
return error_value(E_FPUTS_2);
}
for (i = 1; i < count; i++) {
err = idfputs(vals[0]->v_file, vals[i]->v_str);
if (err > 0)
return error_value(E_FPUTS_3);
}
result.v_type = V_NULL;
return result;
}
S_FUNC VALUE
f_fputstr(int count, VALUE **vals)
{
VALUE result;
int i, err;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vals[0]->v_type != V_FILE)
return error_value(E_FPUTSTR_1);
for (i = 1; i < count; i++) {
if (vals[i]->v_type != V_STR)
return error_value(E_FPUTSTR_2);
}
for (i = 1; i < count; i++) {
err = idfputstr(vals[0]->v_file,
vals[i]->v_str->s_str);
if (err > 0)
return error_value(E_FPUTSTR_3);
}
result.v_type = V_NULL;
return result;
}
S_FUNC VALUE
f_printf(int count, VALUE **vals)
{
VALUE result;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vals[0]->v_type != V_STR)
return error_value(E_PRINTF_1);
i = idprintf(FILEID_STDOUT, vals[0]->v_str->s_str,
count - 1, vals + 1);
if (i)
return error_value(E_PRINTF_2);
result.v_type = V_NULL;
return result;
}
S_FUNC VALUE
f_strprintf(int count, VALUE **vals)
{
VALUE result;
int i;
char *cp;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vals[0]->v_type != V_STR)
return error_value(E_STRPRINTF_1);
math_divertio();
i = idprintf(FILEID_STDOUT, vals[0]->v_str->s_str,
count - 1, vals + 1);
if (i) {
free(math_getdivertedio());
return error_value(E_STRPRINTF_2);
}
cp = math_getdivertedio();
result.v_type = V_STR;
result.v_str = makenewstring(cp);
free(cp);
return result;
}
S_FUNC VALUE
f_fgetc(VALUE *vp)
{
VALUE result;
int ch;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_FILE)
return error_value(E_FGETC_1);
ch = getcharid(vp->v_file);
if (ch == -2)
return error_value(E_FGETC_2);
result.v_type = V_NULL;
if (ch != EOF) {
result.v_type = V_STR;
result.v_str = charstring(ch);
}
return result;
}
S_FUNC VALUE
f_ungetc(VALUE *v1, VALUE *v2)
{
VALUE result;
NUMBER *q;
int ch;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
errno = 0;
if (v1->v_type != V_FILE)
return error_value(E_UNGETC_1);
switch (v2->v_type) {
case V_STR:
ch = v2->v_str->s_str[0];
break;
case V_NUM:
q = v2->v_num;
if (!qisint(q))
return error_value(E_UNGETC_2);
ch = qisneg(q) ? (int)(-q->num.v[0] & 0xff) :
(int)(q->num.v[0] & 0xff);
break;
default:
return error_value(E_UNGETC_2);
}
i = idungetc(v1->v_file, ch);
if (i == EOF)
return error_value(errno);
if (i == -2)
return error_value(E_UNGETC_3);
result.v_type = V_NULL;
return result;
}
S_FUNC VALUE
f_fgetline(VALUE *vp)
{
VALUE result;
STRING *str;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_FILE)
return error_value(E_FGETLINE_1);
i = readid(vp->v_file, 9, &str);
if (i > 0)
return error_value(E_FGETLINE_2);
result.v_type = V_NULL;
if (i == 0) {
result.v_type = V_STR;
result.v_str = str;
}
return result;
}
S_FUNC VALUE
f_fgets(VALUE *vp)
{
VALUE result;
STRING *str;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_FILE)
return error_value(E_FGETS_1);
i = readid(vp->v_file, 1, &str);
if (i > 0)
return error_value(E_FGETS_2);
result.v_type = V_NULL;
if (i == 0) {
result.v_type = V_STR;
result.v_str = str;
}
return result;
}
S_FUNC VALUE
f_fgetstr(VALUE *vp)
{
VALUE result;
STRING *str;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_FILE)
return error_value(E_FGETSTR_1);
i = readid(vp->v_file, 10, &str);
if (i > 0)
return error_value(E_FGETSTR_2);
result.v_type = V_NULL;
if (i == 0) {
result.v_type = V_STR;
result.v_str = str;
}
return result;
}
S_FUNC VALUE
f_fgetfield(VALUE *vp)
{
VALUE result;
STRING *str;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_FILE)
return error_value(E_FGETFIELD_1);
i = readid(vp->v_file, 14, &str);
if (i > 0)
return error_value(E_FGETFIELD_2);
result.v_type = V_NULL;
if (i == 0) {
result.v_type = V_STR;
result.v_str = str;
}
return result;
}
S_FUNC VALUE
f_fgetfile(VALUE *vp)
{
VALUE result;
STRING *str;
int i;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_FILE)
return error_value(E_FGETFILE_1);
i = readid(vp->v_file, 0, &str);
if (i == 1)
return error_value(E_FGETFILE_2);
if (i == 3)
return error_value(E_FGETFILE_3);
result.v_type = V_NULL;
if (i == 0) {
result.v_type = V_STR;
result.v_str = str;
}
return result;
}
S_FUNC VALUE
f_files(int count, VALUE **vals)
{
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (count == 0) {
result.v_type = V_NUM;
result.v_num = itoq((long) MAXFILES);
return result;
}
if ((vals[0]->v_type != V_NUM) || qisfrac(vals[0]->v_num))
return error_value(E_FILES);
result.v_type = V_NULL;
result.v_file = indexid(qtoi(vals[0]->v_num));
if (result.v_file != FILEID_NONE)
result.v_type = V_FILE;
return result;
}
S_FUNC VALUE
f_reverse(VALUE *val)
{
VALUE res;
res.v_type = val->v_type;
res.v_subtype = val->v_subtype;
switch(val->v_type) {
case V_MAT:
res.v_mat = matcopy(val->v_mat);
matreverse(res.v_mat);
break;
case V_LIST:
res.v_list = listcopy(val->v_list);
listreverse(res.v_list);
break;
case V_STR:
res.v_str = stringneg(val->v_str);
if (res.v_str == NULL)
return error_value(E_STRNEG);
break;
default:
math_error("Bad argument type for reverse");
not_reached();
}
return res;
}
S_FUNC VALUE
f_sort(VALUE *val)
{
VALUE res;
res.v_type = val->v_type;
res.v_subtype = val->v_subtype;
switch (val->v_type) {
case V_MAT:
res.v_mat = matcopy(val->v_mat);
matsort(res.v_mat);
break;
case V_LIST:
res.v_list = listcopy(val->v_list);
listsort(res.v_list);
break;
default:
math_error("Bad argument type for sort");
not_reached();
}
return res;
}
S_FUNC VALUE
f_join(int count, VALUE **vals)
{
LIST *lp;
LISTELEM *ep;
VALUE res;
/* initialize VALUE */
res.v_subtype = V_NOSUBTYPE;
lp = listalloc();
while (count-- > 0) {
if (vals[0]->v_type != V_LIST) {
listfree(lp);
printf("Non-list argument for join\n");
res.v_type = V_NULL;
return res;
}
for (ep = vals[0]->v_list->l_first; ep; ep = ep->e_next)
insertlistlast(lp, &ep->e_value);
vals++;
}
res.v_type = V_LIST;
res.v_list = lp;
return res;
}
S_FUNC VALUE
f_head(VALUE *v1, VALUE *v2)
{
VALUE res;
long n;
/* initialize VALUE */
res.v_subtype = V_NOSUBTYPE;
if (v2->v_type != V_NUM || qisfrac(v2->v_num) ||
zge31b(v2->v_num->num))
return error_value(E_HEAD_2);
n = qtoi(v2->v_num);
res.v_type = v1->v_type;
switch (v1->v_type) {
case V_LIST:
if (n == 0)
res.v_list = listalloc();
else if (n > 0)
res.v_list = listsegment(v1->v_list,0,n-1);
else
res.v_list = listsegment(v1->v_list,-n-1,0);
return res;
case V_STR:
if (n == 0)
res.v_str = slink(&_nullstring_);
else if (n > 0)
res.v_str = stringsegment(v1->v_str,0,n-1);
else
res.v_str = stringsegment(v1->v_str,-n-1,0);
if (res.v_str == NULL)
return error_value(E_STRHEAD);
return res;
default:
return error_value(E_HEAD_1);
}
}
S_FUNC VALUE
f_tail(VALUE *v1, VALUE *v2)
{
long n;
VALUE res;
/* initialize VALUE */
res.v_subtype = V_NOSUBTYPE;
if (v2->v_type != V_NUM || qisfrac(v2->v_num) ||
zge31b(v2->v_num->num))
return error_value(E_TAIL_1);
n = qtoi(v2->v_num);
res.v_type = v1->v_type;
switch (v1->v_type) {
case V_LIST:
if (n == 0) {
res.v_list = listalloc();
} else if (n > 0) {
res.v_list = listsegment(v1->v_list,
v1->v_list->l_count - n,
v1->v_list->l_count - 1);
} else {
res.v_list = listsegment(v1->v_list,
v1->v_list->l_count - 1,
v1->v_list->l_count + n);
}
return res;
case V_STR:
if (n == 0) {
res.v_str = slink(&_nullstring_);
} else if (n > 0) {
res.v_str = stringsegment(v1->v_str,
v1->v_str->s_len - n,
v1->v_str->s_len - 1);
} else {
res.v_str = stringsegment(v1->v_str,
v1->v_str->s_len - 1,
v1->v_str->s_len + n);
}
if (res.v_str == V_NULL)
return error_value(E_STRTAIL);
return res;
default:
return error_value(E_TAIL_1);
}
}
S_FUNC VALUE
f_segment(int count, VALUE **vals)
{
VALUE *vp;
long n1, n2;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
vp = vals[1];
if (vp->v_type != V_NUM || qisfrac(vp->v_num) || zge31b(vp->v_num->num))
return error_value(E_SEG_2);
n1 = qtoi(vp->v_num);
n2 = n1;
if (count == 3) {
vp = vals[2];
if (vp->v_type != V_NUM || qisfrac(vp->v_num) ||
zge31b(vp->v_num->num))
return error_value(E_SEG_3);
n2 = qtoi(vp->v_num);
}
vp = vals[0];
result.v_type = vp->v_type;
switch (vp->v_type) {
case V_LIST:
result.v_list = listsegment(vp->v_list, n1, n2);
return result;
case V_STR:
result.v_str = stringsegment(vp->v_str, n1, n2);
if (result.v_str == NULL)
return error_value(E_STRSEG);
return result;
default:
return error_value(E_SEG_1);
}
}
S_FUNC VALUE
f_modify(VALUE *v1, VALUE *v2)
{
FUNC *fp;
LISTELEM *ep;
long s;
VALUE res;
VALUE *vp;
unsigned short subtype;
if (v1->v_type != V_ADDR)
return error_value(E_MODIFY_1);
v1 = v1->v_addr;
if (v2->v_type == V_ADDR)
v2 = v2->v_addr;
if (v2->v_type != V_STR)
return error_value(E_MODIFY_2);
if (v1->v_subtype & V_NONEWVALUE)
return error_value(E_MODIFY_3);
fp = findfunc(adduserfunc(v2->v_str->s_str));
if (!fp)
return error_value(E_MODIFY_4);
switch (v1->v_type) {
case V_LIST:
for (ep = v1->v_list->l_first; ep; ep = ep->e_next) {
subtype = ep->e_value.v_subtype;
*++stack = ep->e_value;
calculate(fp, 1);
stack->v_subtype |= subtype;
ep->e_value = *stack--;
}
break;
case V_MAT:
vp = v1->v_mat->m_table;
s = v1->v_mat->m_size;
while (s-- > 0) {
subtype = vp->v_subtype;
*++stack = *vp;
calculate(fp, 1);
stack->v_subtype |= subtype;
*vp++ = *stack--;
}
break;
case V_OBJ:
vp = v1->v_obj->o_table;
s = v1->v_obj->o_actions->oa_count;
while (s-- > 0) {
subtype = vp->v_subtype;
*++stack = *vp;
calculate(fp, 1);
stack->v_subtype |= subtype;
*vp++ = *stack--;
}
break;
default:
return error_value(E_MODIFY_5);
}
res.v_type = V_NULL;
res.v_subtype = V_NOSUBTYPE;
return res;
}
S_FUNC VALUE
f_forall(VALUE *v1, VALUE *v2)
{
FUNC *fp;
LISTELEM *ep;
long s;
VALUE res;
VALUE *vp;
/* initialize VALUE */
res.v_type = V_NULL;
res.v_subtype = V_NOSUBTYPE;
if (v2->v_type != V_STR) {
math_error("Non-string second argument for forall");
not_reached();
}
fp = findfunc(adduserfunc(v2->v_str->s_str));
if (!fp) {
math_error("Undefined function for forall");
not_reached();
}
switch (v1->v_type) {
case V_LIST:
for (ep = v1->v_list->l_first; ep; ep = ep->e_next) {
copyvalue(&ep->e_value, ++stack);
calculate(fp, 1);
stack--;
}
break;
case V_MAT:
vp = v1->v_mat->m_table;
s = v1->v_mat->m_size;
while (s-- > 0) {
copyvalue(vp++, ++stack);
calculate(fp, 1);
stack--;
}
break;
default:
math_error("Non list or matrix first argument for forall");
not_reached();
}
return res;
}
S_FUNC VALUE
f_select(VALUE *v1, VALUE *v2)
{
LIST *lp;
LISTELEM *ep;
FUNC *fp;
VALUE res;
/* initialize VALUE */
res.v_type = V_LIST;
res.v_subtype = V_NOSUBTYPE;
if (v1->v_type != V_LIST) {
math_error("Non-list first argument for select");
not_reached();
}
if (v2->v_type != V_STR) {
math_error("Non-string second argument for select");
not_reached();
}
fp = findfunc(adduserfunc(v2->v_str->s_str));
if (!fp) {
math_error("Undefined function for select");
not_reached();
}
lp = listalloc();
for (ep = v1->v_list->l_first; ep; ep = ep->e_next) {
copyvalue(&ep->e_value, ++stack);
calculate(fp, 1);
if (testvalue(stack))
insertlistlast(lp, &ep->e_value);
freevalue(stack--);
}
res.v_list = lp;
return res;
}
S_FUNC VALUE
f_count(VALUE *v1, VALUE *v2)
{
LISTELEM *ep;
FUNC *fp;
long s;
long n = 0;
VALUE res;
VALUE *vp;
/* initialize VALUE */
res.v_type = V_NUM;
res.v_subtype = V_NOSUBTYPE;
if (v2->v_type != V_STR) {
math_error("Non-string second argument for select");
not_reached();
}
fp = findfunc(adduserfunc(v2->v_str->s_str));
if (!fp) {
math_error("Undefined function for select");
not_reached();
}
switch (v1->v_type) {
case V_LIST:
for (ep = v1->v_list->l_first; ep; ep = ep->e_next) {
copyvalue(&ep->e_value, ++stack);
calculate(fp, 1);
if (testvalue(stack))
n++;
freevalue(stack--);
}
break;
case V_MAT:
s = v1->v_mat->m_size;
vp = v1->v_mat->m_table;
while (s-- > 0) {
copyvalue(vp++, ++stack);
calculate(fp, 1);
if (testvalue(stack))
n++;
freevalue(stack--);
}
break;
default:
math_error("Bad argument type for count");
not_reached();
break;
}
res.v_num = itoq(n);
return res;
}
S_FUNC VALUE
f_makelist(VALUE *v1)
{
LIST *lp;
VALUE res;
long n;
/* initialize VALUE */
res.v_type = V_NULL;
res.v_subtype = V_NOSUBTYPE;
if (v1->v_type != V_NUM || qisfrac(v1->v_num) || qisneg(v1->v_num)) {
math_error("Bad argument for makelist");
not_reached();
}
if (zge31b(v1->v_num->num)) {
math_error("makelist count >= 2^31");
not_reached();
}
n = qtoi(v1->v_num);
lp = listalloc();
while (n-- > 0)
insertlistlast(lp, &res);
res.v_type = V_LIST;
res.v_list = lp;
return res;
}
S_FUNC VALUE
f_randperm(VALUE *val)
{
VALUE res;
/* initialize VALUE */
res.v_subtype = V_NOSUBTYPE;
res.v_type = val->v_type;
switch (val->v_type) {
case V_MAT:
res.v_mat = matcopy(val->v_mat);
matrandperm(res.v_mat);
break;
case V_LIST:
res.v_list = listcopy(val->v_list);
listrandperm(res.v_list);
break;
default:
math_error("Bad argument type for randperm");
not_reached();
}
return res;
}
S_FUNC VALUE
f_cmdbuf(void)
{
VALUE result;
char *newcp;
size_t cmdbuf_len; /* length of cmdbuf string */
/* initialize VALUE */
result.v_type = V_STR;
result.v_subtype = V_NOSUBTYPE;
cmdbuf_len = strlen(cmdbuf);
newcp = (char *)malloc(cmdbuf_len+1);
if (newcp == NULL) {
math_error("Cannot allocate string in cmdbuf");
not_reached();
}
strlcpy(newcp, cmdbuf, cmdbuf_len+1);
result.v_str = makestring(newcp);
return result;
}
S_FUNC VALUE
f_getenv(VALUE *v1)
{
VALUE result;
char *str;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (v1->v_type != V_STR) {
math_error("Non-string argument for getenv");
not_reached();
}
result.v_type = V_STR;
str = getenv(v1->v_str->s_str);
if (str == NULL)
result.v_type = V_NULL;
else
result.v_str = makenewstring(str);
return result;
}
S_FUNC VALUE
f_isatty(VALUE *vp)
{
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
result.v_type = V_NUM;
if (vp->v_type == V_FILE && isattyid(vp->v_file) == 1) {
result.v_num = itoq(1);
} else {
result.v_num = itoq(0);
}
return result;
}
S_FUNC VALUE
f_calc_tty(void)
{
VALUE res;
if (!calc_tty(FILEID_STDIN))
return error_value(E_TTY);
res.v_type = V_NULL;
res.v_subtype = V_NOSUBTYPE;
return res;
}
S_FUNC VALUE
f_inputlevel (void)
{
VALUE result;
/* initialize VALUE */
result.v_type = V_NUM;
result.v_subtype = V_NOSUBTYPE;
result.v_num = itoq((long) inputlevel());
return result;
}
S_FUNC VALUE
f_calclevel(void)
{
VALUE result;
/* initialize VALUE */
result.v_type = V_NUM;
result.v_subtype = V_NOSUBTYPE;
result.v_num = itoq(calclevel());
return result;
}
S_FUNC VALUE
f_calcpath(void)
{
VALUE result;
/* initialize VALUE */
result.v_type = V_STR;
result.v_subtype = V_NOSUBTYPE;
result.v_str = makenewstring(calcpath);
return result;
}
S_FUNC VALUE
f_access(int count, VALUE **vals)
{
NUMBER *q;
int m;
char *s, *fname;
VALUE result;
size_t len;
int i;
/* initialize VALUE */
result.v_type = V_NULL;
result.v_subtype = V_NOSUBTYPE;
errno = 0;
if (vals[0]->v_type != V_STR)
return error_value(E_ACCESS_1);
fname = vals[0]->v_str->s_str;
m = 0;
if (count == 2) {
switch (vals[1]->v_type) {
case V_NUM:
q = vals[1]->v_num;
if (qisfrac(q) || qisneg(q))
return error_value(E_ACCESS_2);
m = (int)(q->num.v[0] & 7);
break;
case V_STR:
s = vals[1]->v_str->s_str;
len = (long)strlen(s);
while (len-- > 0) {
switch (*s++) {
case 'r': m |= 4; break;
case 'w': m |= 2; break;
case 'x': m |= 1; break;
default: return error_value(E_ACCESS_2);
}
}
break;
case V_NULL:
break;
default:
return error_value(E_ACCESS_2);
}
}
i = access(fname, m);
if (i)
return error_value(errno);
return result;
}
S_FUNC VALUE
f_putenv(int count, VALUE **vals)
{
VALUE result;
char *putenv_str;
/* initialize VALUE */
result.v_type = V_NUM;
result.v_subtype = V_NOSUBTYPE;
/*
* parse args
*/
if (count == 2) {
size_t snprintf_len; /* malloced snprintf buffer length */
/* firewall */
if (vals[0]->v_type != V_STR || vals[1]->v_type != V_STR) {
math_error("Non-string argument for putenv");
not_reached();
}
/* convert putenv("foo","bar") into putenv("foo=bar") */
snprintf_len = vals[0]->v_str->s_len + 1 +
vals[1]->v_str->s_len;
putenv_str = (char *)malloc(snprintf_len+1);
if (putenv_str == NULL) {
math_error("Cannot allocate string in putenv");
not_reached();
}
/*
* The next statement could be:
*
* snprintf(putenv_str, snprintf_len,
* "%s=%s", vals[0]->v_str->s_str,
* vals[1]->v_str->s_str);
*
* however compilers like gcc would issue warnings such as:
*
* null destination pointer
*
* even though we check that putenv_str is non-NULL
* above before using it. Therefore we call strlcpy()
* twice and make an assignment instead to avoid such warnings.
*/
strlcpy(putenv_str,
vals[0]->v_str->s_str,
vals[0]->v_str->s_len+1);
putenv_str[vals[0]->v_str->s_len] = '=';
strlcpy(putenv_str + vals[0]->v_str->s_len + 1,
vals[1]->v_str->s_str,
vals[1]->v_str->s_len+1);
putenv_str[snprintf_len] = '\0';
} else {
/* firewall */
if (vals[0]->v_type != V_STR) {
math_error("Non-string argument for putenv");
not_reached();
}
/* putenv(arg) must be of the form "foo=bar" */
if ((char *)strchr(vals[0]->v_str->s_str, '=') == NULL) {
math_error("putenv single arg string missing =");
not_reached();
}
/*
* make a copy of the arg because subsequent changes
* would change the environment.
*/
putenv_str = (char *)malloc(vals[0]->v_str->s_len + 1);
if (putenv_str == NULL) {
math_error("Cannot allocate string in putenv");
not_reached();
}
strlcpy(putenv_str, vals[0]->v_str->s_str,
vals[0]->v_str->s_len+1);
}
/* return putenv result */
result.v_num = itoq((long) malloced_putenv(putenv_str));
return result;
}
S_FUNC VALUE
f_strpos(VALUE *haystack, VALUE *needle)
{
VALUE result;
char *cpointer;
int cindex;
/* initialize VALUE */
result.v_type = V_NUM;
result.v_subtype = V_NOSUBTYPE;
if (haystack->v_type != V_STR || needle->v_type != V_STR) {
math_error("Non-string argument for index");
not_reached();
}
cpointer = strstr(haystack->v_str->s_str,
needle->v_str->s_str);
if (cpointer == NULL)
cindex = 0;
else
cindex = cpointer - haystack->v_str->s_str + 1;
result.v_num = itoq((long) cindex);
return result;
}
S_FUNC VALUE
f_system(VALUE *vp)
{
VALUE result;
/* initialize VALUE */
result.v_type = V_NUM;
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_STR) {
math_error("Non-string argument for system");
not_reached();
}
if (!allow_exec) {
math_error("execution disallowed by -m");
not_reached();
}
if (conf->calc_debug & CALCDBG_SYSTEM) {
printf("%s\n", vp->v_str->s_str);
}
#if defined(_WIN32) || defined(_WIN64)
/* if the execute length is 0 then just return 0 */
if (vp->v_str->s_len == 0) {
result.v_num = itoq((long)0);
} else {
result.v_num = itoq((long)system(vp->v_str->s_str));
}
#else /* Windows free systems */
result.v_num = itoq((long)system(vp->v_str->s_str));
#endif /* Windows free systems */
return result;
}
S_FUNC VALUE
f_sleep(int count, VALUE **vals)
{
long time;
VALUE res;
NUMBER *q1, *q2;
res.v_type = V_NULL;
res.v_subtype = V_NOSUBTYPE;
#if !defined(_WIN32) && !defined(_WIN64)
if (count > 0) {
if (vals[0]->v_type != V_NUM || qisneg(vals[0]->v_num))
return error_value(E_SLEEP);
if (qisint(vals[0]->v_num)) {
if (zge31b(vals[0]->v_num->num))
return error_value(E_SLEEP);
time = ztoi(vals[0]->v_num->num);
time = sleep(time);
}
else {
q1 = qscale(vals[0]->v_num, 20);
q2 = qint(q1);
qfree(q1);
if (zge31b(q2->num)) {
qfree(q2);
return error_value(E_SLEEP);
}
time = ztoi(q2->num);
qfree(q2);
/* BSD 4.3 usleep has void return */
usleep(time);
return res;
}
} else {
time = sleep(1);
}
if (time) {
res.v_type = V_NUM;
res.v_num = itoq(time);
}
#endif /* Windows free systems */
return res;
}
/*
* set the default output base/mode
*/
S_FUNC NUMBER *
f_base(int count, NUMBER **vals)
{
long base; /* output base/mode */
long oldbase=0; /* output base/mode */
/* deal with just a query */
if (count != 1) {
return base_value(conf->outmode, conf->outmode);
}
/* deal with the special modes first */
if (qisfrac(vals[0])) {
return base_value(math_setmode(MODE_FRAC), conf->outmode);
}
if (vals[0]->num.len > 64/BASEB) {
return base_value(math_setmode(MODE_EXP), conf->outmode);
}
/* set the base, if possible */
base = qtoi(vals[0]);
switch (base) {
case -10:
oldbase = math_setmode(MODE_INT);
break;
case 2:
oldbase = math_setmode(MODE_BINARY);
break;
case 8:
oldbase = math_setmode(MODE_OCTAL);
break;
case 10:
oldbase = math_setmode(MODE_REAL);
break;
case 16:
oldbase = math_setmode(MODE_HEX);
break;
case 1000:
oldbase = math_setmode(MODE_ENG);
break;
default:
math_error("Unsupported base");
not_reached();
break;
}
/* return the old base */
return base_value(oldbase, conf->outmode);
}
/*
* set the default secondary output base/mode
*/
S_FUNC NUMBER *
f_base2(int count, NUMBER **vals)
{
long base; /* output base/mode */
long oldbase=0; /* output base/mode */
/* deal with just a query */
if (count != 1) {
return base_value(conf->outmode2, conf->outmode2);
}
/* deal with the special modes first */
if (qisfrac(vals[0])) {
return base_value(math_setmode2(MODE_FRAC), conf->outmode2);
}
if (vals[0]->num.len > 64/BASEB) {
return base_value(math_setmode2(MODE_EXP), conf->outmode2);
}
/* set the base, if possible */
base = qtoi(vals[0]);
switch (base) {
case 0:
oldbase = math_setmode2(MODE2_OFF);
break;
case -10:
oldbase = math_setmode2(MODE_INT);
break;
case 2:
oldbase = math_setmode2(MODE_BINARY);
break;
case 8:
oldbase = math_setmode2(MODE_OCTAL);
break;
case 10:
oldbase = math_setmode2(MODE_REAL);
break;
case 16:
oldbase = math_setmode2(MODE_HEX);
break;
case 1000:
oldbase = math_setmode2(MODE_ENG);
break;
default:
math_error("Unsupported base");
not_reached();
break;
}
/* return the old base */
return base_value(oldbase, conf->outmode2);
}
/*
* return a numerical 'value' of the mode/base
*/
S_FUNC NUMBER *
base_value(long mode, int defval)
{
NUMBER *result;
/* return the old base */
switch (mode) {
case MODE_DEFAULT:
switch (defval) {
case MODE_DEFAULT:
result = itoq(10);
break;
case MODE_FRAC:
result = qalloc();
itoz(3, &result->den);
break;
case MODE_INT:
result = itoq(-10);
break;
case MODE_REAL:
result = itoq(10);
break;
case MODE_EXP:
result = qalloc();
ztenpow(20, &result->num);
break;
case MODE_ENG:
result = itoq(1000);
break;
case MODE_HEX:
result = itoq(16);
break;
case MODE_OCTAL:
result = itoq(8);
break;
case MODE_BINARY:
result = itoq(2);
break;
case MODE2_OFF:
result = itoq(0);
break;
default:
result = itoq(0);
break;
}
break;
case MODE_FRAC:
result = qalloc();
itoz(3, &result->den);
break;
case MODE_INT:
result = itoq(-10);
break;
case MODE_REAL:
result = itoq(10);
break;
case MODE_EXP:
result = qalloc();
ztenpow(20, &result->num);
break;
case MODE_ENG:
result = itoq(1000);
break;
case MODE_HEX:
result = itoq(16);
break;
case MODE_OCTAL:
result = itoq(8);
break;
case MODE_BINARY:
result = itoq(2);
break;
case MODE2_OFF:
result = itoq(0);
break;
default:
result = itoq(0);
break;
}
return result;
}
S_FUNC VALUE
f_custom(int count, VALUE **vals)
{
VALUE result;
/* initialize VALUE */
result.v_type = V_NULL;
result.v_subtype = V_NOSUBTYPE;
/*
* disable custom functions unless -C was given
*/
if (!allow_custom) {
fprintf(stderr,
#if defined(CUSTOM)
"%sCalc must be run with a -C argument to "
"use custom function\n",
#else /* CUSTOM */
"%sCalc was built with custom functions disabled\n",
#endif /* CUSTOM */
(conf->tab_ok ? "\t" : ""));
return error_value(E_CUSTOM_ERROR);
}
/*
* perform the custom operation
*/
if (count <= 0) {
/* perform the usage function function */
showcustom();
} else {
/* firewall */
if (vals[0]->v_type != V_STR) {
math_error("custom: 1st arg not a string name");
not_reached();
}
/* perform the custom function */
result = custom(vals[0]->v_str->s_str, count-1, vals+1);
}
/*
* return the custom result
*/
return result;
}
S_FUNC VALUE
f_blk(int count, VALUE **vals)
{
int len; /* number of octets to malloc */
int chunk; /* block chunk size */
VALUE result;
int id;
VALUE *vp = NULL;
int type;
/* initialize VALUE */
result.v_type = V_BLOCK;
result.v_subtype = V_NOSUBTYPE;
type = V_NULL;
if (count > 0) {
vp = *vals;
type = vp->v_type;
if (type == V_STR || type == V_NBLOCK || type == V_BLOCK) {
vals++;
count--;
}
}
len = -1; /* signal to use old or zero len */
chunk = -1; /* signal to use old or default chunksize */
if (count > 0 && vals[0]->v_type != V_NULL) {
/* parse len */
if (vals[0]->v_type != V_NUM || qisfrac(vals[0]->v_num))
return error_value(E_BLK_1);
if (qisneg(vals[0]->v_num) || zge31b(vals[0]->v_num->num))
return error_value(E_BLK_2);
len = qtoi(vals[0]->v_num);
}
if (count > 1 && vals[1]->v_type != V_NULL) {
/* parse chunk */
if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num))
return error_value(E_BLK_3);
if (qisneg(vals[1]->v_num) || zge31b(vals[1]->v_num->num))
return error_value(E_BLK_4);
chunk = qtoi(vals[1]->v_num);
}
if (type == V_STR) {
result.v_type = V_NBLOCK;
id = findnblockid(vp->v_str->s_str);
if (id < 0) {
/* create new named block */
result.v_nblock = createnblock(vp->v_str->s_str,
len, chunk);
return result;
}
/* reallocate nblock */
result.v_nblock = reallocnblock(id, len, chunk);
return result;
}
if (type == V_NBLOCK) {
/* reallocate nblock */
result.v_type = V_NBLOCK;
id = vp->v_nblock->id;
result.v_nblock = reallocnblock(id, len, chunk);
return result;
}
if (type == V_BLOCK) {
/* reallocate block */
result.v_type = V_BLOCK;
result.v_block = copyrealloc(vp->v_block, len, chunk);
return result;
}
/* allocate block */
result.v_block = blkalloc(len, chunk);
return result;
}
S_FUNC VALUE
f_blkfree(VALUE *vp)
{
int id;
VALUE result;
/* initialize VALUE */
result.v_type = V_NULL;
result.v_subtype = V_NOSUBTYPE;
id = 0;
switch (vp->v_type) {
case V_NBLOCK:
id = vp->v_nblock->id;
break;
case V_STR:
id = findnblockid(vp->v_str->s_str);
if (id < 0)
return error_value(E_BLKFREE_1);
break;
case V_NUM:
if (qisfrac(vp->v_num) || qisneg(vp->v_num))
return error_value(E_BLKFREE_2);
if (zge31b(vp->v_num->num))
return error_value(E_BLKFREE_3);
id = qtoi(vp->v_num);
break;
default:
return error_value(E_BLKFREE_4);
}
id = removenblock(id);
if (id)
return error_value(id);
return result;
}
S_FUNC VALUE
f_blocks(int count, VALUE **vals)
{
NBLOCK *nblk;
VALUE result;
int id;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (count == 0) {
result.v_type = V_NUM;
result.v_num = itoq((long) countnblocks());
return result;
}
if (vals[0]->v_type != V_NUM || qisfrac(vals[0]->v_num))
return error_value(E_BLOCKS_1);
id = (int) qtoi(vals[0]->v_num);
nblk = findnblock(id);
if (nblk == NULL) {
return error_value(E_BLOCKS_2);
} else {
result.v_type = V_NBLOCK;
result.v_nblock = nblk;
}
return result;
}
S_FUNC VALUE
f_free(int count, VALUE **vals)
{
VALUE result;
VALUE *val;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
result.v_type = V_NULL;
while (count-- > 0) {
val = *vals++;
if (val->v_type == V_ADDR)
freevalue(val->v_addr);
}
return result;
}
S_FUNC VALUE
f_freeglobals(void)
{
VALUE result;
/* initialize VALUE */
result.v_type = V_NULL;
result.v_subtype = V_NOSUBTYPE;
freeglobals();
return result;
}
S_FUNC VALUE
f_freeredc(void)
{
VALUE result;
/* initialize VALUE */
result.v_type = V_NULL;
result.v_subtype = V_NOSUBTYPE;
freeredcdata();
return result;
}
S_FUNC VALUE
f_freestatics(void)
{
VALUE result;
/* initialize VALUE */
result.v_type = V_NULL;
result.v_subtype = V_NOSUBTYPE;
freestatics();
return result;
}
/*
* f_copy - copy consecutive items between values
*
* copy(src, dst [, ssi [, num [, dsi]]])
*
* Copy 'num' consecutive items from 'src' with index 'ssi' to
* 'dest', starting at position with index 'dsi'.
*/
S_FUNC VALUE
f_copy(int count, VALUE **vals)
{
long ssi = 0; /* source start index */
long num = -1; /* number of items to copy (-1 ==> all) */
long dsi = -1; /* destination start index, -1 ==> default */
int errtype; /* error type if unable to perform copy */
VALUE result; /* null if successful */
/* initialize VALUE */
result.v_type = V_NULL;
result.v_subtype = V_NOSUBTYPE;
/*
* parse args
*/
switch(count) {
case 5:
/* parse dsi */
if (vals[4]->v_type != V_NULL) {
if (vals[4]->v_type != V_NUM ||
qisfrac(vals[4]->v_num) ||
qisneg(vals[4]->v_num)) {
return error_value(E_COPY_06);
}
if (zge31b(vals[4]->v_num->num)) {
return error_value(E_COPY_07);
}
dsi = qtoi(vals[4]->v_num);
}
/*FALLTHRU*/
case 4:
/* parse num */
if (vals[3]->v_type != V_NULL) {
if (vals[3]->v_type != V_NUM ||
qisfrac(vals[3]->v_num) ||
qisneg(vals[3]->v_num)) {
return error_value(E_COPY_01);
}
if (zge31b(vals[3]->v_num->num)) {
return error_value(E_COPY_02);
}
num = qtoi(vals[3]->v_num);
}
/*FALLTHRU*/
case 3:
/* parse ssi */
if (vals[2]->v_type != V_NULL) {
if (vals[2]->v_type != V_NUM ||
qisfrac(vals[2]->v_num) ||
qisneg(vals[2]->v_num)) {
return error_value(E_COPY_04);
}
if (zge31b(vals[2]->v_num->num)) {
return error_value(E_COPY_05);
}
ssi = qtoi(vals[2]->v_num);
}
break;
}
/*
* copy
*/
errtype = copystod(vals[0], ssi, num, vals[1], dsi);
if (errtype > 0)
return error_value(errtype);
return result;
}
/*
* f_blkcpy - copy consecutive items between values
*
* copy(dst, src [, num [, dsi [, ssi]]])
*
* Copy 'num' consecutive items from 'src' with index 'ssi' to
* 'dest', starting at position with index 'dsi'.
*/
S_FUNC VALUE
f_blkcpy(int count, VALUE **vals)
{
VALUE *args[5]; /* args to re-order */
VALUE null_value; /* dummy argument */
/* initialize VALUE */
null_value.v_subtype = V_NOSUBTYPE;
/*
* parse args into f_copy order
*/
args[0] = vals[1];
args[1] = vals[0];
null_value.v_type = V_NULL;
args[2] = &null_value;
args[3] = &null_value;
args[4] = &null_value;
switch(count) {
case 5:
args[2] = vals[4];
args[4] = vals[3];
args[3] = vals[2];
break;
case 4:
count = 5;
args[4] = vals[3];
args[3] = vals[2];
break;
case 3:
count = 4;
args[3] = vals[2];
break;
}
/*
* copy
*/
return f_copy(count, args);
}
S_FUNC VALUE
f_sha1(int count, VALUE **vals)
{
VALUE result;
HASH *state; /* pointer to hash state to use */
int i; /* vals[i] to hash */
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* arg check
*/
if (count == 0) {
/* return an initial hash state */
result.v_type = V_HASH;
result.v_hash = hash_init(SHA1_HASH_TYPE, NULL);
} else if (count == 1 && vals[0]->v_type == V_HASH &&
vals[0]->v_hash->hashtype == SHA1_HASH_TYPE) {
/* if just a hash value, finalize it */
state = hash_copy(vals[0]->v_hash);
result.v_type = V_NUM;
result.v_num = qalloc();
result.v_num->num = hash_final(state);
hash_free(state);
} else {
/*
* If the first value is a hash, use that as
* the initial hash state
*/
if (vals[0]->v_type == V_HASH &&
vals[0]->v_hash->hashtype == SHA1_HASH_TYPE) {
state = hash_copy(vals[0]->v_hash);
i = 1;
/*
* otherwise use the default initial state
*/
} else {
state = hash_init(SHA1_HASH_TYPE, NULL);
i = 0;
}
/*
* hash the remaining values
*/
do {
state = hash_value(SHA1_HASH_TYPE, vals[i], state);
} while (++i < count);
/*
* return the current hash state
*/
result.v_type = V_HASH;
result.v_hash = state;
}
/* return the result */
return result;
}
S_FUNC VALUE
f_argv(int count, VALUE **vals)
{
int arg; /* the argv_value string index */
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* arg check
*/
if (count == 0) {
/* return the argc count */
result.v_type = V_NUM;
result.v_num = itoq((long) argc_value);
} else {
/* firewall */
if (vals[0]->v_type != V_NUM || qisfrac(vals[0]->v_num) ||
qisneg(vals[0]->v_num) || zge31b(vals[0]->v_num->num)) {
math_error("argv argument must be a integer [0,2^31)");
not_reached();
}
/* determine the arg value of the argv() function */
arg = qtoi(vals[0]->v_num);
/* argv(0) is program or script_name if -f filename was used */
if (arg == 0) {
if (script_name == NULL) {
/* paranoia */
result.v_type = V_NULL;
} else {
result.v_type = V_STR;
result.v_str = makenewstring(script_name);
}
/* return the n-th argv string */
} else if (arg < argc_value && argv_value[arg-1] != NULL) {
result.v_type = V_STR;
result.v_str = makestring(strdup(argv_value[arg-1]));
} else {
result.v_type = V_NULL;
}
}
/* return the result */
return result;
}
S_FUNC VALUE
f_version(void)
{
VALUE result;
/* return the calc version string */
result.v_type = V_STR;
result.v_subtype = V_NOSUBTYPE;
result.v_str = makestring(strdup(version()));
return result;
}
/*
* f_versin - versed sine
*/
S_FUNC VALUE
f_versin(int count, VALUE **vals)
{
VALUE result;
COMPLEX *c;
NUMBER *eps;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_VERSIN_1);
}
eps = vals[1]->v_num;
}
/*
* compute trig function to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qversin(vals[0]->v_num, eps);
result.v_type = V_NUM;
break;
case V_COM:
c = c_versin(vals[0]->v_com, eps);
if (c == NULL) {
return error_value(E_VERSIN_3);
}
result.v_com = c;
result.v_type = V_COM;
/*
* case: complex trig function returned real, convert result to NUMBER
*/
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_VERSIN_2);
}
return result;
}
/*
* f_aversin - inverse versed sine
*/
S_FUNC VALUE
f_aversin(int count, VALUE **vals)
{
VALUE arg1; /* 1st arg if it is a COMPLEX value */
VALUE result; /* value to return */
COMPLEX *c; /* COMPLEX trig result */
NUMBER *eps; /* epsilon error tolerance */
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_AVERSIN_1);
}
eps = vals[1]->v_num;
}
/*
* compute inverse trig function to a given error tolerance
*/
arg1 = *vals[0];
if (arg1.v_type == V_NUM) {
/* try to compute result using real triv function */
result.v_num = qaversin_or_NULL(arg1.v_num, eps);
/*
* case: trig function returned a NUMBER
*/
if (result.v_num != NULL) {
result.v_type = V_NUM;
/*
* case: trig function returned NULL - need to try COMPLEX trig function
*/
} else {
/* convert NUMBER argument from NUMBER to COMPLEX */
arg1.v_com = qqtoc(arg1.v_num, &_qzero_);
arg1.v_type = V_COM;
}
}
if (arg1.v_type == V_COM) {
/*
* case: argument was COMPLEX or
* trig function returned NULL and argument was converted to COMPLEX
*/
c = c_aversin(arg1.v_com, eps);
if (c == NULL) {
return error_value(E_AVERSIN_3);
}
result.v_com = c;
result.v_type = V_COM;
/*
* case: complex trig function returned real, convert result to NUMBER
*/
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
}
if (arg1.v_type != V_NUM && arg1.v_type != V_COM) {
/*
* case: argument type is not valid for this function
*/
return error_value(E_AVERSIN_2);
}
return result;
}
/*
* f_coversin - coversed sine
*/
S_FUNC VALUE
f_coversin(int count, VALUE **vals)
{
VALUE result;
COMPLEX *c;
NUMBER *eps;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_COVERSIN_1);
}
eps = vals[1]->v_num;
}
/*
* compute trig function to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qcoversin(vals[0]->v_num, eps);
result.v_type = V_NUM;
break;
case V_COM:
c = c_coversin(vals[0]->v_com, eps);
if (c == NULL) {
return error_value(E_COVERSIN_3);
}
result.v_com = c;
result.v_type = V_COM;
/*
* case: complex trig function returned real, convert result to NUMBER
*/
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_COVERSIN_2);
}
return result;
}
/*
* f_acoversin - inverse coversed sine
*/
S_FUNC VALUE
f_acoversin(int count, VALUE **vals)
{
VALUE arg1; /* 1st arg if it is a COMPLEX value */
VALUE result; /* value to return */
COMPLEX *c; /* COMPLEX trig result */
NUMBER *eps; /* epsilon error tolerance */
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_ACOVERSIN_1);
}
eps = vals[1]->v_num;
}
/*
* compute inverse trig function to a given error tolerance
*/
arg1 = *vals[0];
if (arg1.v_type == V_NUM) {
/* try to compute result using real triv function */
result.v_num = qacoversin_or_NULL(arg1.v_num, eps);
/*
* case: trig function returned a NUMBER
*/
if (result.v_num != NULL) {
result.v_type = V_NUM;
/*
* case: trig function returned NULL - need to try COMPLEX trig function
*/
} else {
/* convert NUMBER argument from NUMBER to COMPLEX */
arg1.v_com = qqtoc(arg1.v_num, &_qzero_);
arg1.v_type = V_COM;
}
}
if (arg1.v_type == V_COM) {
/*
* case: argument was COMPLEX or
* trig function returned NULL and argument was converted to COMPLEX
*/
c = c_acoversin(arg1.v_com, eps);
if (c == NULL) {
return error_value(E_ACOVERSIN_3);
}
result.v_com = c;
result.v_type = V_COM;
/*
* case: complex trig function returned real, convert result to NUMBER
*/
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
}
if (arg1.v_type != V_NUM && arg1.v_type != V_COM) {
/*
* case: argument type is not valid for this function
*/
return error_value(E_ACOVERSIN_2);
}
return result;
}
/*
* f_vercos - versed cosine
*/
S_FUNC VALUE
f_vercos(int count, VALUE **vals)
{
VALUE result;
COMPLEX *c;
NUMBER *eps;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_VERCOS_1);
}
eps = vals[1]->v_num;
}
/*
* compute trig function to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qvercos(vals[0]->v_num, eps);
result.v_type = V_NUM;
break;
case V_COM:
c = c_vercos(vals[0]->v_com, eps);
if (c == NULL) {
return error_value(E_VERCOS_3);
}
result.v_com = c;
result.v_type = V_COM;
/*
* case: complex trig function returned real, convert result to NUMBER
*/
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_VERCOS_2);
}
return result;
}
/*
* f_avercos - inverse versed cosine
*/
S_FUNC VALUE
f_avercos(int count, VALUE **vals)
{
VALUE arg1; /* 1st arg if it is a COMPLEX value */
VALUE result; /* value to return */
COMPLEX *c; /* COMPLEX trig result */
NUMBER *eps; /* epsilon error tolerance */
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_AVERCOS_1);
}
eps = vals[1]->v_num;
}
/*
* compute inverse trig function to a given error tolerance
*/
arg1 = *vals[0];
if (arg1.v_type == V_NUM) {
/* try to compute result using real triv function */
result.v_num = qavercos_or_NULL(arg1.v_num, eps);
/*
* case: trig function returned a NUMBER
*/
if (result.v_num != NULL) {
result.v_type = V_NUM;
/*
* case: trig function returned NULL - need to try COMPLEX trig function
*/
} else {
/* convert NUMBER argument from NUMBER to COMPLEX */
arg1.v_com = qqtoc(arg1.v_num, &_qzero_);
arg1.v_type = V_COM;
}
}
if (arg1.v_type == V_COM) {
/*
* case: argument was COMPLEX or
* trig function returned NULL and argument was converted to COMPLEX
*/
c = c_avercos(arg1.v_com, eps);
if (c == NULL) {
return error_value(E_AVERCOS_3);
}
result.v_com = c;
result.v_type = V_COM;
/*
* case: complex trig function returned real, convert result to NUMBER
*/
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
}
if (arg1.v_type != V_NUM && arg1.v_type != V_COM) {
/*
* case: argument type is not valid for this function
*/
return error_value(E_AVERCOS_2);
}
return result;
}
/*
* f_covercos - coversed cosine
*/
S_FUNC VALUE
f_covercos(int count, VALUE **vals)
{
VALUE result;
COMPLEX *c;
NUMBER *eps;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_COVERCOS_1);
}
eps = vals[1]->v_num;
}
/*
* compute trig function to a given error tolerance
*/
switch (vals[0]->v_type) {
case V_NUM:
result.v_num = qcovercos(vals[0]->v_num, eps);
result.v_type = V_NUM;
break;
case V_COM:
c = c_covercos(vals[0]->v_com, eps);
if (c == NULL) {
return error_value(E_COVERCOS_3);
}
result.v_com = c;
result.v_type = V_COM;
/*
* case: complex trig function returned real, convert result to NUMBER
*/
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
break;
default:
return error_value(E_COVERCOS_2);
}
return result;
}
/*
* f_acovercos - inverse coversed cosine
*/
S_FUNC VALUE
f_acovercos(int count, VALUE **vals)
{
VALUE arg1; /* 1st arg if it is a COMPLEX value */
VALUE result; /* value to return */
COMPLEX *c; /* COMPLEX trig result */
NUMBER *eps; /* epsilon error tolerance */
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
/*
* set error tolerance for builtin function
*
* Use eps VALUE arg if given and value is in a valid range.
*/
eps = conf->epsilon;
if (count == 2) {
if (verify_eps(vals[1]) == false) {
return error_value(E_ACOVERCOS_1);
}
eps = vals[1]->v_num;
}
/*
* compute inverse trig function to a given error tolerance
*/
arg1 = *vals[0];
if (arg1.v_type == V_NUM) {
/* try to compute result using real triv function */
result.v_num = qacovercos_or_NULL(arg1.v_num, eps);
/*
* case: trig function returned a NUMBER
*/
if (result.v_num != NULL) {
result.v_type = V_NUM;
/*
* case: trig function returned NULL - need to try COMPLEX trig function
*/
} else {
/* convert NUMBER argument from NUMBER to COMPLEX */
arg1.v_com = qqtoc(arg1.v_num, &_qzero_);
arg1.v_type = V_COM;
}
}
if (arg1.v_type == V_COM) {
/*
* case: argument was COMPLEX or
* trig function returned NULL and argument was converted to COMPLEX
*/
c = c_acovercos(arg1.v_com, eps);
if (c == NULL) {
return error_value(E_ACOVERCOS_3);
}
result.v_com = c;
result.v_type = V_COM;
/*
* case: complex trig function returned real, convert result to NUMBER
*/
if (cisreal(c)) {
result.v_num = c_to_q(c, true);
result.v_type = V_NUM;
}
}
if (arg1.v_type != V_NUM && arg1.v_type != V_COM) {
/*
* case: argument type is not valid for this function
*/
return error_value(E_ACOVERCOS_2);
}
return result;
}
#endif /* !FUNCLIST */
/*
* builtins - List of primitive built-in functions
*
* NOTE: This table is also used by the help/Makefile builtin rule to
* form the builtin help file. This rule will cause a sed script
* to strip this table down into a just the information needed
* to print builtin function list: b_name, b_minargs, b_maxargs
* and b_desc. All other struct elements will be converted to 0.
* The sed script expects to find entries of the form:
*
* {"...", number, number, stuff, stuff, stuff, stuff,
* "...."},
*
* please keep this table in that form.
*
* For nice output, when the description of function (b_desc)
* gets too long (extends into col 79) you should chop the
* line and add "\n\t\t\t", that's newline and 3 tabs.
* For example the description:
*
* ... very long description that goes beyond col 79
*
* should be written as:
*
* "... very long description that\n\t\t\tgoes beyond col 79"},
*
* fields:
* b_name name of built-in function
* b_minargs minimum number of arguments
* b_maxargs maximum number of arguments
* b_flags special handling flags
* b_opcode opcode which makes the call quick
* b_numfunc routine to calculate numeric function
* b_valfunc routine to calculate general values
* b_desc description of function
*/
STATIC CONST struct builtin builtins[] = {
{"abs", 1, 2, 0, OP_ABS, {.null = NULL}, {.null = NULL},
"absolute value within accuracy b"},
{"access", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_access},
"determine accessibility of file a for mode b"},
{"acos", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_acos},
"inverse cosine of a within accuracy b"},
{"acosh", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_acosh},
"inverse hyperbolic cosine of a within accuracy b"},
{"acot", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_acot},
"inverse cotangent of a within accuracy b"},
{"acoth", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_acoth},
"inverse hyperbolic cotangent of a within accuracy b"},
{"acovercos", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_acovercos},
"inverse coversed cosine of a within accuracy b"},
{"acoversin", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_acoversin},
"inverse coversed sine of a within accuracy b"},
{"acsc", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_acsc},
"inverse cosecant of a within accuracy b"},
{"acsch", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_acsch},
"inverse csch of a within accuracy b"},
{"agd", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_agd},
"inverse Gudermannian function"},
{"append", 1, IN, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_listappend},
"append values to end of list"},
{"appr", 1, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_appr},
"approximate a by multiple of b using rounding c"},
{"arg", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_arg},
"argument (the angle) of complex number"},
{"argv", 0, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_argv},
"calc argc or argv string"},
{"asec", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_asec},
"inverse secant of a within accuracy b"},
{"asech", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_asech},
"inverse hyperbolic secant of a within accuracy b"},
{"asin", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_asin},
"inverse sine of a within accuracy b"},
{"asinh", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_asinh},
"inverse hyperbolic sine of a within accuracy b"},
{"assoc", 0, 0, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_assoc},
"create new association array"},
{"atan", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_atan},
"inverse tangent of a within accuracy b"},
{"atan2", 2, 3, FE, OP_NOP, {.numfunc_3 = qatan2}, {.null = NULL},
"angle to point (b,a) within accuracy c"},
{"atanh", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_atanh},
"inverse hyperbolic tangent of a within accuracy b"},
{"avercos", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_avercos},
"inverse versed cosine of a within accuracy b"},
{"aversin", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_aversin},
"inverse versed sine of a within accuracy b"},
{"avg", 0, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_avg},
"arithmetic mean of values"},
{"base", 0, 1, 0, OP_NOP, {.numfunc_cnt = f_base}, {.null = NULL},
"set default output base"},
{"base2", 0, 1, 0, OP_NOP, {.numfunc_cnt = f_base2}, {.null = NULL},
"set default secondary output base"},
{"bernoulli", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_bern},
"Bernoulli number for index a"},
{"bit", 2, 2, 0, OP_BIT, {.null = NULL}, {.null = NULL},
"whether bit b in value a is set"},
{"blk", 0, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_blk},
"block with or without name, octet number, chunksize"},
{"blkcpy", 2, 5, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_blkcpy},
"copy value to/from a block: blkcpy(d,s,len,di,si)"},
{"blkfree", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_blkfree},
"free all storage from a named block"},
{"blocks", 0, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_blocks},
"named block with specified index, or null value"},
{"bround", 1, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_bround},
"round value a to b number of binary places"},
{"btrunc", 1, 2, 0, OP_NOP, {.numfunc_cnt = f_btrunc}, {.null = NULL},
"truncate a to b number of binary places"},
{"calclevel", 0, 0, 0, OP_NOP, {.null = NULL}, {.valfunc_0 = f_calclevel},
"current calculation level"},
{"calcpath", 0, 0, 0, OP_NOP, {.null = NULL}, {.valfunc_0 = f_calcpath},
"current CALCPATH search path value"},
{"calc_tty", 0, 0, 0, OP_NOP, {.null = NULL}, {.valfunc_0 = f_calc_tty},
"set tty for interactivity"},
{"catalan", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_catalan},
"catalan number for index a"},
{"ceil", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_ceil},
"smallest integer greater than or equal to number"},
{"cfappr", 1, 3, 0, OP_NOP, {.numfunc_cnt = f_cfappr}, {.null = NULL},
"approximate a within accuracy b using\n"
"\t\t\tcontinued fractions"},
{"cfsim", 1, 2, 0, OP_NOP, {.numfunc_cnt = f_cfsim}, {.null = NULL},
"simplify number using continued fractions"},
{"char", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_char},
"character corresponding to integer value"},
{"cmdbuf", 0, 0, 0, OP_NOP, {.null = NULL}, {.valfunc_0 = f_cmdbuf},
"command buffer"},
{"cmp", 2, 2, 0, OP_CMP, {.null = NULL}, {.null = NULL},
"compare values returning -1, 0, or 1"},
{"comb", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_comb},
"combinatorial number a!/b!(a-b)!"},
{"config", 1, 2, 0, OP_SETCONFIG, {.null = NULL}, {.null = NULL},
"set or read configuration value"},
{"conj", 1, 1, 0, OP_CONJUGATE, {.null = NULL}, {.null = NULL},
"complex conjugate of value"},
{"copy", 2, 5, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_copy},
"copy value to/from a block: copy(s,d,len,si,di)"},
{"cos", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_cos},
"cosine of value a within accuracy b"},
{"cosh", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_cosh},
"hyperbolic cosine of a within accuracy b"},
{"cot", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_cot},
"cotangent of a within accuracy b"},
{"coth", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_coth},
"hyperbolic cotangent of a within accuracy b"},
{"count", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_count},
"count listr/matrix elements satisfying some condition"},
{"covercos", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_covercos},
"coversed cosine of value a within accuracy b"},
{"coversin", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_coversin},
"coversed sine of value a within accuracy b"},
{"cp", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_cp},
"cross product of two vectors"},
{"csc", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_csc},
"cosecant of a within accuracy b"},
{"csch", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_csch},
"hyperbolic cosecant of a within accuracy b"},
{"ctime", 0, 0, 0, OP_NOP, {.null = NULL}, {.valfunc_0 = f_ctime},
"date and time as string"},
{"custom", 0, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_custom},
"custom builtin function interface"},
{"d2dm", 3, 4, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_d2dm},
"convert a to b deg, c min, rounding type d\n"},
{"d2dms", 4, 5, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_d2dms},
"convert a to b deg, c min, d sec, rounding type e\n"},
{"d2g", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_d2g},
"convert degrees to gradians"},
{"d2r", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_d2r},
"convert degrees to radians"},
{"delete", 2, 2, FA, OP_NOP, {.null = NULL}, {.valfunc_2 = f_listdelete},
"delete element from list a at position b"},
{"den", 1, 1, 0, OP_DENOMINATOR, {.numfunc_1 = qden}, {.null = NULL},
"denominator of fraction"},
{"det", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_det},
"determinant of matrix"},
{"digit", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_digit},
"digit at specified decimal place of number"},
{"digits", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_digits},
"number of digits in base b representation of a"},
{"display", 0, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_display},
"number of decimal digits for displaying numbers"},
{"dm2d", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_dm2d},
"convert a deg, b min to degrees, rounding type c\n"},
{"dms2d", 3, 4, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_dms2d},
"convert a deg, b min, c sec to degrees, rounding type d\n"},
{"dp", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_dp},
"dot product of two vectors"},
{"epsilon", 0, 1, 0, OP_SETEPSILON, {.null = NULL}, {.null = NULL},
"set or read allowed error for real calculations"},
{"errcount", 0, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_errcount},
"set or read error count"},
{"errmax", 0, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_errmax},
"set or read maximum for error count"},
{"errno", 0, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_errno},
"set or read calc_errno"},
{"error", 0, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_error},
"generate error value"},
{"estr", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_estr},
"exact text string representation of value"},
{"euler", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_euler},
"Euler number"},
{"eval", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_eval},
"evaluate expression from string to value"},
{"exp", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_exp},
"exponential of value a within accuracy b"},
{"fact", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_fact},
"factorial"},
{"factor", 1, 3, 0, OP_NOP, {.numfunc_cnt = f_factor}, {.null = NULL},
"lowest prime factor < b of a, return c if error"},
{"fclose", 0, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_fclose},
"close file"},
{"fcnt", 2, 2, 0, OP_NOP, {.numfunc_2 = f_faccnt}, {.null = NULL},
"count of times one number divides another"},
{"feof", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_feof},
"whether EOF reached for file"},
{"ferror", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_ferror},
"whether error occurred for file"},
{"fflush", 0, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_fflush},
"flush output to file(s)"},
{"fgetc", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_fgetc},
"read next char from file"},
{"fgetfield", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_fgetfield},
"read next white-space delimited field from file"},
{"fgetfile", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_fgetfile},
"read to end of file"},
{"fgetline", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_fgetline},
"read next line from file, newline removed"},
{"fgets", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_fgets},
"read next line from file, newline is kept"},
{"fgetstr", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_fgetstr},
"read next null-terminated string from file, null\n"
"\t\t\tcharacter is kept"},
{"fib", 1, 1, 0, OP_NOP, {.numfunc_1 = qfib}, {.null = NULL},
"Fibonacci number F(n)"},
{"files", 0, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_files},
"return opened file or max number of opened files"},
{"floor", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_floor},
"greatest integer less than or equal to number"},
{"fopen", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_fopen},
"open file name a in mode b"},
{"forall", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_forall},
"do function for all elements of list or matrix"},
{"fpathopen", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_fpathopen},
"open file name a in mode b, search for a along\n"
"\t\t\tCALCPATH or path c"},
{"fprintf", 2, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_fprintf},
"print formatted output to opened file"},
{"fputc", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_fputc},
"write a character to a file"},
{"fputs", 2, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_fputs},
"write one or more strings to a file"},
{"fputstr", 2, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_fputstr},
"write one or more null-terminated strings to a file"},
{"frac", 1, 1, 0, OP_FRAC, {.numfunc_1 = qfrac}, {.null = NULL},
"fractional part of value"},
{"free", 0, IN, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_free},
"free listed or all global variables"},
{"freebernoulli", 0, 0, 0, OP_NOP, {.null = NULL}, {.valfunc_0 = f_freebern},
"free stored Bernoulli numbers"},
{"freeeuler", 0, 0, 0, OP_NOP, {.null = NULL}, {.valfunc_0 = f_freeeuler},
"free stored Euler numbers"},
{"freeglobals", 0, 0, 0, OP_NOP, {.null = NULL}, {.valfunc_0 = f_freeglobals},
"free all global and visible static variables"},
{"freeredc", 0, 0, 0, OP_NOP, {.null = NULL}, {.valfunc_0 = f_freeredc},
"free redc data cache"},
{"freestatics", 0, 0, 0, OP_NOP, {.null = NULL}, {.valfunc_0 = f_freestatics},
"free all un-scoped static variables"},
{"frem", 2, 2, 0, OP_NOP, {.numfunc_2 = qfacrem}, {.null = NULL},
"number with all occurrences of factor removed"},
{"freopen", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_freopen},
"reopen a file stream to a named file"},
{"fscan", 2, IN, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_fscan},
"scan a file for assignments to one or\n"
"\t\t\tmore variables"},
{"fscanf", 2, IN, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_fscanf},
"formatted scan of a file for assignment to one\n"
"\t\t\tor more variables"},
{"fseek", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_fseek},
"seek to position b (offset from c) in file a"},
{"fsize", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_fsize},
"return the size of the file"},
{"ftell", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_ftell},
"return the file position"},
{"g2d", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_g2d},
"convert gradians to degrees"},
{"g2gm", 3, 4, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_g2gm},
"convert a to b grads, c min, rounding type d\n"},
{"g2gms", 4, 5, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_g2gms},
"convert a to b grads, c min, d sec, rounding type e\n"},
{"g2r", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_g2r},
"convert gradians to radians"},
{"gcd", 1, IN, 0, OP_NOP, {.numfunc_cnt = f_gcd}, {.null = NULL},
"greatest common divisor"},
{"gcdrem", 2, 2, 0, OP_NOP, {.numfunc_2 = qgcdrem}, {.null = NULL},
"a divided repeatedly by gcd with b"},
{"gd", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_gd},
"Gudermannian function"},
{"getenv", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_getenv},
"value of environment variable (or NULL)"},
{"gm2g", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_gm2g},
"convert a grads, b min to grads, rounding type c\n"},
{"gms2g", 3, 4, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_gms2g},
"convert a grads, b min, c sec to grads, rounding type d\n"},
{"h2hm", 3, 4, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_h2hm},
"convert a to b hours, c min, rounding type d\n"},
{"h2hms", 4, 5, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_h2hms},
"convert a to b hours, c min, d sec, rounding type e\n"},
{"hash", 1, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_hash},
"return non-negative hash value for one or\n"
"\t\t\tmore values"},
{"head", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_head},
"return list of specified number at head of a list"},
{"highbit", 1, 1, 0, OP_HIGHBIT, {.null = NULL}, {.null = NULL},
"high bit number in base 2 representation"},
{"hm2h", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_hm2h},
"convert a hours, b min to hours, rounding type c\n"},
{"hmean", 0, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_hmean},
"harmonic mean of values"},
{"hms2h", 3, 4, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_hms2h},
"convert a hours, b min, c sec to hours, rounding type d\n"},
{"hnrmod", 4, 4, 0, OP_NOP, {.numfunc_4 = f_hnrmod}, {.null = NULL},
"v mod h*2^n+r, h>0, n>0, r = -1, 0 or 1"},
{"hypot", 2, 3, FE, OP_NOP, {.numfunc_3 = qhypot}, {.null = NULL},
"hypotenuse of right triangle within accuracy c"},
{"ilog", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_ilog},
"integral log of a to integral base b"},
{"ilog10", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_ilog10},
"integral log of a number base 10"},
{"ilog2", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_ilog2},
"integral log of a number base 2"},
{"ilogn", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_ilog},
"same is ilog"},
{"im", 1, 1, 0, OP_IM, {.null = NULL}, {.null = NULL},
"imaginary part of complex number"},
{"indices", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_indices},
"indices of a specified assoc or mat value"},
{"inputlevel", 0, 0, 0, OP_NOP, {.null = NULL}, {.valfunc_0 = f_inputlevel},
"current input depth"},
{"insert", 2, IN, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_listinsert},
"insert values c ... into list a at position b"},
{"int", 1, 1, 0, OP_INT, {.numfunc_1 = qint}, {.null = NULL},
"integer part of value"},
{"inverse", 1, 1, 0, OP_INVERT, {.null = NULL}, {.null = NULL},
"multiplicative inverse of value"},
{"iroot", 2, 2, 0, OP_NOP, {.numfunc_2 = qiroot}, {.null = NULL},
"integer b'th root of a"},
{"isalnum", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_isalnum},
"whether character is alpha-numeric"},
{"isalpha", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_isalpha},
"whether character is alphabetic"},
{"isassoc", 1, 1, 0, OP_ISASSOC, {.null = NULL}, {.null = NULL},
"whether a value is an association"},
{"isatty", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_isatty},
"whether a file is a tty"},
{"isblk", 1, 1, 0, OP_ISBLK, {.null = NULL}, {.null = NULL},
"whether a value is a block"},
{"iscntrl", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_iscntrl},
"whether character is a control character"},
{"isconfig", 1, 1, 0, OP_ISCONFIG, {.null = NULL}, {.null = NULL},
"whether a value is a config state"},
{"isdefined", 1, 1, 0, OP_ISDEFINED, {.null = NULL}, {.null = NULL},
"whether a string names a function"},
{"isdigit", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_isdigit},
"whether character is a digit"},
{"iserror", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_iserror},
"where a value is an error"},
{"iseven", 1, 1, 0, OP_ISEVEN, {.null = NULL}, {.null = NULL},
"whether a value is an even integer"},
{"isfile", 1, 1, 0, OP_ISFILE, {.null = NULL}, {.null = NULL},
"whether a value is a file"},
{"isgraph", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_isgraph},
"whether character is a graphical character"},
{"ishash", 1, 1, 0, OP_ISHASH, {.null = NULL}, {.null = NULL},
"whether a value is a hash state"},
{"isident", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_isident},
"returns 1 if identity matrix"},
{"isint", 1, 1, 0, OP_ISINT, {.null = NULL}, {.null = NULL},
"whether a value is an integer"},
{"islist", 1, 1, 0, OP_ISLIST, {.null = NULL}, {.null = NULL},
"whether a value is a list"},
{"islower", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_islower},
"whether character is lower case"},
{"ismat", 1, 1, 0, OP_ISMAT, {.null = NULL}, {.null = NULL},
"whether a value is a matrix"},
{"ismult", 2, 2, 0, OP_NOP, {.numfunc_2 = f_ismult}, {.null = NULL},
"whether a is a multiple of b"},
{"isnull", 1, 1, 0, OP_ISNULL, {.null = NULL}, {.null = NULL},
"whether a value is the null value"},
{"isnum", 1, 1, 0, OP_ISNUM, {.null = NULL}, {.null = NULL},
"whether a value is a number"},
{"isobj", 1, 1, 0, OP_ISOBJ, {.null = NULL}, {.null = NULL},
"whether a value is an object"},
{"isobjtype", 1, 1, 0, OP_ISOBJTYPE, {.null = NULL}, {.null = NULL},
"whether a string names an object type"},
{"isoctet", 1, 1, 0, OP_ISOCTET, {.null = NULL}, {.null = NULL},
"whether a value is an octet"},
{"isodd", 1, 1, 0, OP_ISODD, {.null = NULL}, {.null = NULL},
"whether a value is an odd integer"},
{"isprime", 1, 2, 0, OP_NOP, {.numfunc_cnt = f_isprime}, {.null = NULL},
"whether a is a small prime, return b if error"},
{"isprint", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_isprint},
"whether character is printable"},
{"isptr", 1, 1, 0, OP_ISPTR, {.null = NULL}, {.null = NULL},
"whether a value is a pointer"},
{"ispunct", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_ispunct},
"whether character is a punctuation"},
{"isqrt", 1, 1, 0, OP_NOP, {.numfunc_1 = qisqrt}, {.null = NULL},
"integer part of square root"},
{"isrand", 1, 1, 0, OP_ISRAND, {.null = NULL}, {.null = NULL},
"whether a value is a subtractive 100 state"},
{"israndom", 1, 1, 0, OP_ISRANDOM, {.null = NULL}, {.null = NULL},
"whether a value is a Blum state"},
{"isreal", 1, 1, 0, OP_ISREAL, {.null = NULL}, {.null = NULL},
"whether a value is a real number"},
{"isrel", 2, 2, 0, OP_NOP, {.numfunc_2 = f_isrel}, {.null = NULL},
"whether two numbers are relatively prime"},
{"issimple", 1, 1, 0, OP_ISSIMPLE, {.null = NULL}, {.null = NULL},
"whether value is a simple type"},
{"isspace", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_isspace},
"whether character is a space character"},
{"issq", 1, 1, 0, OP_NOP, {.numfunc_1 = f_issquare}, {.null = NULL},
"whether or not number is a square"},
{"isstr", 1, 1, 0, OP_ISSTR, {.null = NULL}, {.null = NULL},
"whether a value is a string"},
{"istype", 2, 2, 0, OP_ISTYPE, {.null = NULL}, {.null = NULL},
"whether the type of a is same as the type of b"},
{"isupper", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_isupper},
"whether character is upper case"},
{"isxdigit", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_isxdigit},
"whether character is a hexadecimal digit"},
{"jacobi", 2, 2, 0, OP_NOP, {.numfunc_2 = qjacobi}, {.null = NULL},
"-1 = > a is not quadratic residue mod b\n"
"\t\t\t1 = > b is composite, or a is quad residue of b"},
{"join", 1, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_join},
"join one or more lists into one list"},
{"lcm", 1, IN, 0, OP_NOP, {.numfunc_cnt = f_lcm}, {.null = NULL},
"least common multiple"},
{"lcmfact", 1, 1, 0, OP_NOP, {.numfunc_1 = qlcmfact}, {.null = NULL},
"lcm of all integers up till number"},
{"lfactor", 2, 2, 0, OP_NOP, {.numfunc_2 = qlowfactor}, {.null = NULL},
"lowest prime factor of a in first b primes"},
{"links", 1, 1, 0, OP_LINKS, {.null = NULL}, {.null = NULL},
"links to number or string value"},
{"list", 0, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_list},
"create list of specified values"},
{"ln", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_ln},
"natural logarithm of value a within accuracy b"},
{"log", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_log},
"base 10 logarithm of value a within accuracy b"},
{"log2", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_log2},
"base 2 logarithm of value a within accuracy b"},
{"logn", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_logn},
"base b logarithm of value a within accuracy c"},
{"lowbit", 1, 1, 0, OP_LOWBIT, {.null = NULL}, {.null = NULL},
"low bit number in base 2 representation"},
{"ltol", 1, 2, FE, OP_NOP, {.numfunc_2 = f_legtoleg}, {.null = NULL},
"leg-to-leg of unit right triangle (sqrt(1 - a^2))"},
{"makelist", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_makelist},
"create a list with a null elements"},
{"matdim", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_matdim},
"number of dimensions of matrix"},
{"matfill", 2, 3, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_matfill},
"fill matrix with value b (value c on diagonal)"},
{"matmax", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_matmax},
"maximum index of matrix a dim b"},
{"matmin", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_matmin},
"minimum index of matrix a dim b"},
{"matsum", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_matsum},
"sum the numeric values in a matrix"},
{"mattrace", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_mattrace},
"return the trace of a square matrix"},
{"mattrans", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_mattrans},
"transpose of matrix"},
{"max", 0, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_max},
"maximum value"},
{"memsize", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_memsize},
"number of octets used by the value, including overhead"},
{"meq", 3, 3, 0, OP_NOP, {.numfunc_3 = f_meq}, {.null = NULL},
"whether a and b are equal modulo c"},
{"min", 0, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_min},
"minimum value"},
{"minv", 2, 2, 0, OP_NOP, {.numfunc_2 = qminv}, {.null = NULL},
"inverse of a modulo b"},
{"mmin", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_mmin},
"a mod b value with smallest abs value"},
{"mne", 3, 3, 0, OP_NOP, {.numfunc_3 = f_mne}, {.null = NULL},
"whether a and b are not equal modulo c"},
{"mod", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_mod},
"residue of a modulo b, rounding type c"},
{"modify", 2, 2, FA, OP_NOP, {.null = NULL}, {.valfunc_2 = f_modify},
"modify elements of a list or matrix"},
{"name", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_name},
"name assigned to block or file"},
{"near", 2, 3, 0, OP_NOP, {.numfunc_cnt = f_near}, {.null = NULL},
"sign of (abs(a-b) - c)"},
{"newerror", 0, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_newerror},
"create new error type with message a"},
{"nextcand", 1, 5, 0, OP_NOP, {.numfunc_cnt = f_nextcand}, {.null = NULL},
"smallest value = = d mod e > a, ptest(a,b,c) true"},
{"nextprime", 1, 2, 0, OP_NOP, {.numfunc_cnt = f_nprime}, {.null = NULL},
"return next small prime, return b if err"},
{"norm", 1, 1, 0, OP_NORM, {.null = NULL}, {.null = NULL},
"norm of a value (square of absolute value)"},
{"null", 0, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_null},
"null value"},
{"num", 1, 1, 0, OP_NUMERATOR, {.numfunc_1 = qnum}, {.null = NULL},
"numerator of fraction"},
{"ord", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_ord},
"integer corresponding to character value"},
{"param", 1, 1, 0, OP_ARGVALUE, {.null = NULL}, {.null = NULL},
"value of parameter n (or parameter count if n\n"
"\t\t\tis zero)"},
{"perm", 2, 2, 0, OP_NOP, {.numfunc_2 = qperm}, {.null = NULL},
"permutation number a!/(a-b)!"},
{"pfact", 1, 1, 0, OP_NOP, {.numfunc_1 = qpfact}, {.null = NULL},
"product of primes up till number"},
{"pi", 0, 1, FE, OP_NOP, {.numfunc_1 = qpi}, {.null = NULL},
"value of pi accurate to within epsilon"},
{"pix", 1, 2, 0, OP_NOP, {.numfunc_cnt = f_pix}, {.null = NULL},
"number of primes < = a < 2^32, return b if error"},
{"places", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_places},
"places after \"decimal\" point (-1 if infinite)"},
{"pmod", 3, 3, 0, OP_NOP, {.numfunc_3 = qpowermod}, {.null = NULL},
"mod of a power (a ^ b (mod c))"},
{"polar", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_polar},
"complex value of polar coordinate (a * exp(b*1i))"},
{"poly", 1, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_poly},
"evaluates a polynomial given its coefficients\n"
"\t\t\tor coefficient-list"},
{"pop", 1, 1, FA, OP_NOP, {.null = NULL}, {.valfunc_1 = f_listpop},
"pop value from front of list"},
{"popcnt", 1, 2, 0, OP_NOP, {.numfunc_cnt = f_popcnt}, {.null = NULL},
"number of bits in a that match b (or 1)"},
{"power", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_power},
"value a raised to the power b within accuracy c"},
{"prevcand", 1, 5, 0, OP_NOP, {.numfunc_cnt = f_prevcand}, {.null = NULL},
"largest value = = d mod e < a, ptest(a,b,c) true"},
{"prevprime", 1, 2, 0, OP_NOP, {.numfunc_cnt = f_pprime}, {.null = NULL},
"return previous small prime, return b if err"},
{"printf", 1, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_printf},
"print formatted output to stdout"},
{"prompt", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_prompt},
"prompt for input line using value a"},
{"protect", 1, 3, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_protect},
"read or set protection level for variable"},
{"ptest", 1, 3, 0, OP_NOP, {.numfunc_cnt = f_primetest}, {.null = NULL},
"probabilistic primality test"},
{"push", 1, IN, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_listpush},
"push values onto front of list"},
{"putenv", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_putenv},
"define an environment variable"},
{"quo", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_quo},
"integer quotient of a by b, rounding type c"},
{"quomod", 4, 5, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_quomod},
"set c and d to quotient and remainder of a\n"
"\t\t\tdivided by b"},
{"r2d", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_r2d},
"convert radians to degrees"},
{"r2g", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_r2g},
"convert radians to gradians"},
{"rand", 0, 2, 0, OP_NOP, {.numfunc_cnt = f_rand}, {.null = NULL},
"subtractive 100 random number [0,2^64), [0,a), or [a,b)"},
{"randbit", 0, 1, 0, OP_NOP, {.numfunc_cnt = f_randbit}, {.null = NULL},
"subtractive 100 random number [0,2^a)"},
{"random", 0, 2, 0, OP_NOP, {.numfunc_cnt = f_random}, {.null = NULL},
"Blum-Blum-Shub random number [0,2^64), [0,a), or [a,b)"},
{"randombit", 0, 1, 0, OP_NOP, {.numfunc_cnt = f_randombit}, {.null = NULL},
"Blum-Blum-Sub random number [0,2^a)"},
{"randperm", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_randperm},
"random permutation of a list or matrix"},
{"rcin", 2, 2, 0, OP_NOP, {.numfunc_2 = qredcin}, {.null = NULL},
"convert normal number a to REDC number mod b"},
{"rcmul", 3, 3, 0, OP_NOP, {.numfunc_3 = qredcmul}, {.null = NULL},
"multiply REDC numbers a and b mod c"},
{"rcout", 2, 2, 0, OP_NOP, {.numfunc_2 = qredcout}, {.null = NULL},
"convert REDC number a mod b to normal number"},
{"rcpow", 3, 3, 0, OP_NOP, {.numfunc_3 = qredcpower}, {.null = NULL},
"raise REDC number a to power b mod c"},
{"rcsq", 2, 2, 0, OP_NOP, {.numfunc_2 = qredcsquare}, {.null = NULL},
"square REDC number a mod b"},
{"re", 1, 1, 0, OP_RE, {.null = NULL}, {.null = NULL},
"real part of complex number"},
{"remove", 1, 1, FA, OP_NOP, {.null = NULL}, {.valfunc_1 = f_listremove},
"remove value from end of list"},
{"reverse", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_reverse},
"reverse a copy of a matrix or list"},
{"rewind", 0, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_rewind},
"rewind file(s)"},
{"rm", 1, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_rm},
"remove file(s), -f turns off no-such-file errors"},
{"root", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_root},
"value a taken to the b'th root within accuracy c"},
{"round", 1, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_round},
"round value a to b number of decimal places"},
{"rsearch", 2, 4, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_rsearch},
"reverse search matrix or list for value b\n"
"\t\t\tstarting at index c"},
{"runtime", 0, 0, 0, OP_NOP, {.numfunc_0 = f_runtime}, {.null = NULL},
"user and kernel mode CPU time in seconds"},
{"saveval", 1, 1, 0, OP_SAVEVAL, {.null = NULL}, {.null = NULL},
"set flag for saving values"},
{"scale", 2, 2, 0, OP_SCALE, {.null = NULL}, {.null = NULL},
"scale value up or down by a power of two"},
{"scan", 1, IN, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_scan},
"scan standard input for assignment to one\n"
"\t\t\tor more variables"},
{"scanf", 2, IN, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_scanf},
"formatted scan of standard input for assignment\n"
"\t\t\tto variables"},
{"search", 2, 4, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_search},
"search matrix or list for value b starting\n"
"\t\t\tat index c"},
{"sec", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_sec},
"sec of a within accuracy b"},
{"sech", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_sech},
"hyperbolic secant of a within accuracy b"},
{"seed", 0, 0, 0, OP_NOP, {.numfunc_0 = f_seed}, {.null = NULL},
"return a 64 bit seed for a pseudo-random generator"},
{"segment", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_segment},
"specified segment of specified list"},
{"select", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_select},
"form sublist of selected elements from list"},
{"setbit", 2, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_setbit},
"set specified bit in string"},
{"sgn", 1, 1, 0, OP_SGN, {.numfunc_1 = qsign}, {.null = NULL},
"sign of value (-1, 0, 1)"},
{"sha1", 0, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_sha1},
"Secure Hash Algorithm (SHS-1 FIPS Pub 180-1)"},
{"sin", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_sin},
"sine of value a within accuracy b"},
{"sinh", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_sinh},
"hyperbolic sine of a within accuracy b"},
{"size", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_size},
"total number of elements in value"},
{"sizeof", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_sizeof},
"number of octets used to hold the value"},
{"sleep", 0, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_sleep},
"suspend operation for a seconds"},
{"sort", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_sort},
"sort a copy of a matrix or list"},
{"sqrt", 1, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_sqrt},
"square root of value a within accuracy b"},
{"srand", 0, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_srand},
"seed the rand() function"},
{"srandom", 0, 4, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_srandom},
"seed the random() function"},
{"ssq", 1, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_ssq},
"sum of squares of values"},
{"stoponerror", 0, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_stoponerror},
"assign value to stoponerror flag"},
{"str", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_str},
"simple value converted to string"},
{"strcasecmp", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_strcasecmp},
"compare two strings case independent"},
{"strcat", 1,IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_strcat},
"concatenate strings together"},
{"strcmp", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_strcmp},
"compare two strings"},
{"strcpy", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_strcpy},
"copy string to string"},
{"strerror", 0, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_strerror},
"string describing error type"},
{"strlen", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_strlen},
"length of string"},
{"strncasecmp", 3, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_3 = f_strncasecmp},
"compare strings a, b to c characters case independent"},
{"strncmp", 3, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_3 = f_strncmp},
"compare strings a, b to c characters"},
{"strncpy", 3, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_3 = f_strncpy},
"copy up to c characters from string to string"},
{"strpos", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_strpos},
"index of first occurrence of b in a"},
{"strprintf", 1, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_strprintf},
"return formatted output as a string"},
{"strscan", 2, IN, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_strscan},
"scan a string for assignments to one or more variables"},
{"strscanf", 2, IN, FA, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_strscanf},
"formatted scan of string for assignments to variables"},
{"strtolower", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_strtolower},
"Make string lower case"},
{"strtoupper", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_strtoupper},
"Make string upper case"},
{"substr", 3, 3, 0, OP_NOP, {.null = NULL}, {.valfunc_3 = f_substr},
"substring of a from position b for c chars"},
{"sum", 0, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_sum},
"sum of list or object sums and/or other terms"},
{"swap", 2, 2, 0, OP_SWAP, {.null = NULL}, {.null = NULL},
"swap values of variables a and b (can be dangerous)"},
{"system", 1, 1, 0, OP_NOP, {.null = NULL}, {.valfunc_1 = f_system},
"call Unix command"},
{"systime", 0, 0, 0, OP_NOP, {.numfunc_0 = f_systime}, {.null = NULL},
"kernel mode CPU time in seconds"},
{"tail", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_tail},
"retain list of specified number at tail of list"},
{"tan", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_tan},
"tangent of a within accuracy b"},
{"tanh", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_tanh},
"hyperbolic tangent of a within accuracy b"},
{"test", 1, 1, 0, OP_TEST, {.null = NULL}, {.null = NULL},
"test that value is nonzero"},
{"time", 0, 0, 0, OP_NOP, {.numfunc_0 = f_time}, {.null = NULL},
"number of seconds since 00:00:00 1 Jan 1970 UTC"},
{"trunc", 1, 2, 0, OP_NOP, {.numfunc_cnt = f_trunc}, {.null = NULL},
"truncate a to b number of decimal places"},
{"ungetc", 2, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_2 = f_ungetc},
"unget char read from file"},
{"usertime", 0, 0, 0, OP_NOP, {.numfunc_0 = f_usertime}, {.null = NULL},
"user mode CPU time in seconds"},
{"vercos", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_vercos},
"versed cosine of value a within accuracy b"},
{"versin", 1, 2, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_versin},
"versed sine of value a within accuracy b"},
{"version", 0, 0, 0, OP_NOP, {.null = NULL}, {.valfunc_0 = f_version},
"calc version string"},
{"xor", 1, IN, 0, OP_NOP, {.null = NULL}, {.valfunc_cnt = f_xor},
"logical xor"},
/* end of table */
{NULL, 0, 0, 0, 0, {.null = NULL}, {.null = NULL},
NULL}
};
/*
* Show the list of primitive built-in functions
*
* When FUNCLIST is defined, we are being compiled by rules from the help
* sub-directory to form a program that will produce the main part of the
* builtin help file.
*
* See the builtin rule in the help/Makefile for details.
*/
#if defined(FUNCLIST)
int
main(void)
{
CONST struct builtin *bp; /* current function */
printf("\nName\tArgs\tDescription\n\n");
for (bp = builtins; bp->b_name; bp++) {
printf("%-9s ", bp->b_name);
if (bp->b_maxargs == IN)
printf("%d+ ", bp->b_minargs);
else if (bp->b_minargs == bp->b_maxargs)
printf("%-6d", bp->b_minargs);
else
printf("%d-%-4d", bp->b_minargs, bp->b_maxargs);
printf("%s\n", bp->b_desc);
}
printf("\n");
return 0; /* exit(0); */
}
#else /* FUNCLIST */
void
showbuiltins(void)
{
CONST struct builtin *bp; /* current function */
int i;
printf("\nName\tArgs\tDescription\n\n");
for (bp = builtins, i = 0; bp->b_name; bp++, i++) {
printf("%-14s ", bp->b_name);
if (bp->b_maxargs == IN)
printf("%d+ ", bp->b_minargs);
else if (bp->b_minargs == bp->b_maxargs)
printf("%-6d", bp->b_minargs);
else
printf("%d-%-4d", bp->b_minargs, bp->b_maxargs);
printf("%s\n", bp->b_desc);
if (i == 32) {
i = 0;
if (getchar() == 27)
break;
}
}
printf("\n");
}
#endif /* FUNCLIST */
#if !defined(FUNCLIST)
/*
* Call a built-in function.
* Arguments to the function are on the stack, but are not removed here.
* Functions are either purely numeric, or else can take any value type.
*
* given:
* index index on where to scan in builtin table
* argcount number of args
* stck arguments on the stack
*/
VALUE
builtinfunc(long index, int argcount, VALUE *stck)
{
VALUE *sp; /* pointer to stack entries */
VALUE **vpp; /* pointer to current value address */
CONST struct builtin *bp; /* builtin function to be called */
NUMBER *numargs[IN]; /* numeric arguments for function */
VALUE *valargs[IN]; /* addresses of actual arguments */
VALUE result; /* general result of function */
long i;
if ((unsigned long)index >=
(sizeof(builtins) / sizeof(builtins[0])) - 1) {
math_error("Bad built-in function index");
not_reached();
}
bp = &builtins[index];
if (argcount < bp->b_minargs) {
math_error("Too few arguments for builtin function \"%s\"",
bp->b_name);
not_reached();
}
if ((argcount > bp->b_maxargs) || (argcount > IN)) {
math_error("Too many arguments for builtin function \"%s\"",
bp->b_name);
not_reached();
}
/*
* If an address was passed, then point at the real variable,
* otherwise point at the stack value itself (unless the function
* is very special).
*/
sp = stck - argcount + 1;
vpp = valargs;
for (i = argcount; i > 0; i--) {
if ((sp->v_type != V_ADDR) || (bp->b_flags & FA))
*vpp = sp;
else
*vpp = sp->v_addr;
sp++;
vpp++;
}
/*
* Handle general values if the function accepts them.
*/
if (bp->b_valfunc.null != NULL) {
vpp = valargs;
if ((bp->b_minargs == 1) && (bp->b_maxargs == 1))
result = (*bp->b_valfunc.valfunc_1)(vpp[0]);
else if ((bp->b_minargs == 2) && (bp->b_maxargs == 2))
result = (*bp->b_valfunc.valfunc_2)(vpp[0], vpp[1]);
else if ((bp->b_minargs == 3) && (bp->b_maxargs == 3))
result = (*bp->b_valfunc.valfunc_3)(vpp[0], vpp[1], vpp[2]);
else if ((bp->b_minargs == 4) && (bp->b_maxargs == 4))
result = (*bp->b_valfunc.valfunc_4)(vpp[0],vpp[1],vpp[2],vpp[3]);
else
result = (*bp->b_valfunc.valfunc_cnt)(argcount, vpp);
return result;
}
/*
* Function must be purely numeric, so handle that.
*/
vpp = valargs;
for (i = 0; i < argcount; i++) {
if ((*vpp)->v_type != V_NUM) {
math_error("Non-real argument for builtin function %s",
bp->b_name);
not_reached();
}
numargs[i] = (*vpp)->v_num;
vpp++;
}
result.v_type = V_NUM;
result.v_subtype = V_NOSUBTYPE;
if (!(bp->b_flags & FE) && (bp->b_minargs != bp->b_maxargs)) {
result.v_num = (*bp->b_numfunc.numfunc_cnt)(argcount, numargs);
return result;
}
if ((bp->b_flags & FE) && (argcount < bp->b_maxargs))
numargs[argcount++] = conf->epsilon;
switch (argcount) {
case 0:
result.v_num = (*bp->b_numfunc.numfunc_0)();
break;
case 1:
result.v_num = (*bp->b_numfunc.numfunc_1)(numargs[0]);
break;
case 2:
result.v_num = (*bp->b_numfunc.numfunc_2)(numargs[0], numargs[1]);
break;
case 3:
result.v_num = (*bp->b_numfunc.numfunc_3)(numargs[0],
numargs[1], numargs[2]);
break;
case 4:
result.v_num = (*bp->b_numfunc.numfunc_4)(numargs[0], numargs[1],
numargs[2], numargs[3]);
break;
default:
math_error("Bad builtin function call");
not_reached();
}
return result;
}
/*
* Return the index of a built-in function given its name.
* Returns minus one if the name is not known.
*/
int
getbuiltinfunc(char *name)
{
CONST struct builtin *bp;
for (bp = builtins; bp->b_name; bp++) {
if ((*name == *bp->b_name) && (strcmp(name, bp->b_name) == 0))
return (bp - builtins);
}
return -1;
}
/*
* Given the index of a built-in function, return its name.
*/
char *
builtinname(long index)
{
if ((unsigned long)index >=
(sizeof(builtins) / sizeof(builtins[0])) - 1)
return "";
return builtins[index].b_name;
}
/*
* Given the index of a built-in function, and the number of arguments seen,
* determine if the number of arguments are legal. This routine is called
* during parsing time.
*/
void
builtincheck(long index, int count)
{
CONST struct builtin *bp;
if ((unsigned long)index >=
(sizeof(builtins) / sizeof(builtins[0])) - 1) {
math_error("Unknown built in index");
not_reached();
}
bp = &builtins[index];
if (count < bp->b_minargs)
scanerror(T_NULL,
"Too few arguments for builtin function \"%s\"",
bp->b_name);
if (count > bp->b_maxargs)
scanerror(T_NULL,
"Too many arguments for builtin function \"%s\"",
bp->b_name);
}
/*
* Return the opcode for a built-in function that can be used to avoid
* the function call at all.
*/
int
builtinopcode(long index)
{
if ((unsigned long)index >=
(sizeof(builtins) / sizeof(builtins[0])) - 1)
return OP_NOP;
return builtins[index].b_opcode;
}
/*
* Show the error-values created by newerror(str).
*/
void
showerrors(void)
{
int i;
if (nexterrnum == E__USERDEF)
printf("No new error-values created\n");
for (i = E__USERDEF; i < nexterrnum; i++)
printf("%d: %s\n", i,
namestr(&newerrorstr, i - E__USERDEF));
}
/*
* malloced_putenv - Keep track of malloced environment variable storage
*
* given:
* str a malloced string which will be given to putenv
*
* returns:
* putenv() return value
*
* NOTE: The caller MUST pass a string that the caller has previously malloced.
*/
S_FUNC int
malloced_putenv(char *str)
{
char *value; /* location of the value part of the str argument */
char *old_val; /* previously stored (or inherited) env value */
int found_cnt; /* number of active env_pool entries found */
struct env_pool *new; /* new e_pool */
int i;
/*
* firewall
*/
if (str == NULL) {
math_error("malloced_putenv given a NULL pointer!!");
not_reached();
}
if (str[0] == '=') {
math_error("malloced_putenv = is first character in string!!");
not_reached();
}
/*
* determine the place where getenv would return
*/
value = strchr(str, '=');
if (value == NULL) {
math_error("malloced_putenv = not found in string!!");
not_reached();
}
++value;
/*
* lookup for an existing environment value
*/
*(value-1) = '\0';
old_val = getenv(str);
*(value-1) = '=';
/*
* If we have the value in our environment, look for a
* previously malloced string and free it
*/
if (old_val != NULL && env_pool_cnt > 0) {
for (i=0, found_cnt=0;
i < env_pool_max && found_cnt < env_pool_cnt;
++i) {
/* skip an unused entry */
if (e_pool[i].getenv == NULL) {
continue;
}
++found_cnt;
/* look for the 1st match */
if (e_pool[i].getenv == value) {
/* found match, free the storage */
if (e_pool[i].putenv != NULL) {
free(e_pool[i].putenv);
}
e_pool[i].getenv = NULL;
--env_pool_cnt;
break;
}
}
}
/*
* ensure that we have room in the e_pool
*/
if (env_pool_max == 0) {
/* allocate an initial pool (with one extra guard value) */
new = (struct env_pool *)malloc((ENV_POOL_CHUNK+1) *
sizeof(struct env_pool));
if (new == NULL) {
math_error("malloced_putenv malloc failed");
not_reached();
}
e_pool = new;
env_pool_max = ENV_POOL_CHUNK;
for (i=0; i <= ENV_POOL_CHUNK; ++i) {
e_pool[i].getenv = NULL;
}
} else if (env_pool_cnt >= env_pool_max) {
/* expand the current pool (with one extra guard value) */
new = (struct env_pool *)realloc(e_pool,
(env_pool_max+ENV_POOL_CHUNK+1) *
sizeof(struct env_pool));
if (new == NULL) {
math_error("malloced_putenv realloc failed");
not_reached();
}
e_pool = new;
for (i=env_pool_max; i <= env_pool_max + ENV_POOL_CHUNK; ++i) {
e_pool[i].getenv = NULL;
}
env_pool_max += ENV_POOL_CHUNK;
}
/*
* store our data into the first e_pool entry
*/
for (i=0; i < env_pool_max; ++i) {
/* skip used entries */
if (e_pool[i].getenv != NULL) {
continue;
}
/* store in this free entry and stop looping */
e_pool[i].getenv = value;
e_pool[i].putenv = str;
++env_pool_cnt;
break;
}
if (i >= env_pool_max) {
math_error("malloced_putenv missed unused entry!!");
not_reached();
}
/*
* finally, do the putenv action
*/
return putenv(str);
}
#endif /* FUNCLIST */