/*
*/ /* c90tea.cpp is an interpreter of the Teapro programming language */ /* c90tea.cpp begun on 2004/11/12 */ /* The computer program c90tea.cpp may be used for free by anyone, */ /* but there is no warranty of any kind whatsoever on c90tea.cpp. */ /* The computer language teapro may be used for free by anyone, */ /* but there is no warranty of any kind whatsoever on teapro. */ /* This computer program source code, c90tea.cpp, may be used for free by */ /* anyone, but there is no warranty of any kind whatsoever on c90tea.cpp. */ /* People need computer software that actually works. */ /* header files */ #include*//* stdio.h */ #include /* stdlib.h */ #include /* time.h */ #include /* math.h */ /* C99 uses CLOCKS_PER_SEC instead of CLK_TCK */ #ifndef CLOCKS_PER_SEC #define CLOCKS_PER_SEC CLK_TCK #endif /* plines is the max number of lines for a program */ /* pstack is the number of the depth of the link stack */ /* vstrings is the number of string variables */ /* vslong is the max length of a string */ /* vdecimals is the number of decimal variables */ /* vstack is the number of depth of subroutines possible */ /* darray is the number of elements in the decimal array */ /* sarray is the number of elements in the string array */ /* vcharname is the length of the variable name arrays */ /* maxstring is the max length of variable length strings */ #define PLINES 20010 #define PSTACK 20010 #define VSTRINGS 4000 #define VSLONG 8192 /* 16384 */ #define VDECIMALS 2000 #define VSTACK 2000 #define DARRAY 99000 /* decimal array */ #define SARRAY 2000 #define VCHARNAME 2000 #define MAXSTRING 100000000 /* 100,000,000 */ /* utility prototypes below */ int tfni_compare_strings(char *sp1, char *sp2, long np_long); int tfni_char_type(char cp_1); int tfni_is_digits(char *sp1, int ip_long); int tfni_string_to_integer(char *sp1, int ip_long); long tfnn_string_lookup(char *sp1, long np1, char *sp2, long np2); long tfnn_string_char_search(char *sp1, long np_long, char cp1); long tfnn_hash(char *sp1, int ip_long); void tsub_blank(char *sp1, long np_long); void tsub_blank_escapes(char *sp1, long np_long); void tsub_bug(char *sp1); void tsub_case_lower(char *sp1, long np_long); void tsub_case_upper(char *sp1, long np_long); void tsub_copy(char *sp1, char *sp2, long np_long); void tsub_double_to_string(void); void tsub_inp79(void); void tsub_inp1024(void); void tsub_line_of_char(char *sp1, char cp1, long np_long); void tsub_make_long_string(char **psp1, long np_long); void tsub_out79(char *sp1, int ip_long); void tsub_show_pline(int ip_index, char *sp1, int ip_long); void tsub_show_pline_by_index(int ip_index); void tsub_show_vdecimal_info(int ip_index); void tsub_show_vstring_info(int ip_index); void tsub_string_to_double(char *sp1, int ip_long); void tsub_timeline(void); void tsub_use_append(char *psp_app, long np_app); void tsub_use_insert321(long np_beg); void tsub_use_replace(long np_beg, char *psp_rep, long np_rep); void tsub_use_delete21(long np_beg, long np_long); void tsub_use_move12(void); void tsub_use_move21(void); void tsub_use_trim_left(char *psp_str, long np_long); void tsub_use_trim_right(char *psp_str, long np_long); void tsub_pass_delete(long np_beg, long np_long); void tsub_pass_insert(long np_beg, char *sp1, long np_long); void tsub_pass_trim_left(void); void tsub_pass_trim_right(void); /* utility prototypes above */ /* fetch and store prototypes below */ /* these use sg_pass, ng_pass_lg, dg_1pass */ void sub_fetch_decimal_variable_1dbl(char *sp_var); void sub_fetch_decimal_variable_2dbl(char *sp_var); void sub_fetch_decimal_variable_lng(char *sp_var); void sub_fetch_decimal_variable_int(char *sp_var); void sub_fetch_decimal_pointer_dbl(char *sp_var, double *dp_var); void sub_fetch_string_expression_use(int ip_byte); void sub_fetch_string_pass(int ip_byte); void sub_fetch_string3(int ip_byte, char **psp_1, long *pnp_long); void sub_fetch_string_byref(int ip_byte); void sub_store_decimal_variable(char *sp_var); void sub_store_decimal_variable_in_link(void); void sub_store_string3(char *sp_var, char *sp_string, long np_long); void sub_store_string_in_link(char *sp_string, long np_long); /* fetch and store prototypes above */ /* program preparation prototypes below */ void sub_prep_literal_numbers(void); void sub_prep_literal_strings(void); void sub_prep_format1(void); void sub_prep_format2(void); void sub_prep_no_spaces(void); void sub_prep_split(int *ip_colon); void sub_prep_variables_str(char *ps_vars, int *pi_vars_lg); void sub_prep_variables_dec(char *ps_vars, int *pi_vars_lg); void sub_prep_evar(int pi_type, char *ps_pline, char *ps_vars, int pi_vars_lg); /* program preparation prototypes below */ void sub_program_variable_overlap(char *sp1, int ip1, char *sp2, int ip2); void sub_program_validate_commands(void); void sub_program_validate_variable(int ip_beg, int ip_type); void sub_program_validate_var_last(int ip_beg); void sub_program_validate_expression(int ip_beg, int ip_type); void sub_program_error_end(char *sp_1, int ip_long); void sub_program_help(void); void sub_program_info(void); void sub_program_initialize(int ip_which); void sub_program_link_commands(void); void sub_program_link_dift_dwhi(void); void sub_program_link_esub(void); void sub_program_link_var(void); void sub_program_load(int ip_mode); void sub_program_run(void); void sub_program_show(void); void sub_command_dabs(int ip1); void sub_command_dbad(void); void sub_command_dbug(void); void sub_command_dcut(void); void sub_command_dduo(void); void sub_command_dfac(void); void sub_command_dfak(void); void sub_command_dift_dwhi(void); void sub_command_dinc(int ip1); void sub_command_dpow(void); void sub_command_dset(void); void sub_command_dsys(void); void sub_command_dtoi(int ip1); void sub_command_dtos(int ip1); void sub_command_itod(void); void sub_command_evar(void); void sub_command_ends(void); void sub_command_file(int ip1); void sub_command_sapp(void); void sub_command_schs(int ip1); void sub_command_scnt(void); void sub_command_scut(void); void sub_command_sdat(void); void sub_command_sdel(void); void sub_command_sdot(void); void sub_command_sift_swhi(void); void sub_command_sinp(void); void sub_command_sins(void); void sub_command_sisc(int ip1); void sub_command_slen(int ip1); void sub_command_slok(int ip1); void sub_command_spkd(int ip1); void sub_command_ssor(void); void sub_command_sout(int ip1); void sub_command_spar(void); void sub_command_srep(void); void sub_command_sset(void); void sub_command_stod(int ip1); void sub_command_stoi(int ip1); void sub_command_strl(int ip1); void sub_command_sswp(void); void sub_command_ssys(void); void sub_command_stoe(void); /* prototypes above */ /* global variables are below */ /* program lines globals below */ char sg_path[80]; int ig_path; char sg_loadprogram[80]; int ig_loadprogram; char sg_version[60]; char *psga_plines[PLINES]; int iga_plines_lg[PLINES]; int iga_link_commands[PLINES]; double dg_plines_done = 0; char sg_pline[200]; char *psg_pline = NULL; int ig_pline_lg; int ig_pline_ix; int ig_plines_total_count; /* global true=1 */ int ig_true; /* variable strings globals below */ char *psga_strings[VSTRINGS]; long nga_strings_lg[VSTRINGS]; /* variable decimals globals below */ double dga_decimals[VDECIMALS]; /* decimal array */ double dga_darray[DARRAY]; /* string array */ char *psga_sarray[SARRAY]; int iga_sarray_lg[SARRAY]; /* sg_pass, ng_pass_lg, dg_1pass are used */ /* for passing to/from fetch and store */ char sg_pass[VSLONG]; long ng_pass_lg; char sg_buff1[VSLONG]; long ng_buff1_lg; char sg_buff2[VSLONG]; long ng_buff2_lg; /* psg_1,ng_1 string pointer */ /* use tsub_make_long_string(char **psp1, long np_long); */ char *psg_use1 = NULL; long ng_use1 = 0; char *psg_use2 = NULL; long ng_use2 = 0; char *psg_use3 = NULL; long ng_use3 = 0; char *psg_use4 = NULL; long ng_use4 = 0; char *psg_byref = NULL; long ng_byref = 0; char sg_byref[100]; /* dg_1pass,ig_pass,ng_pass for passing numbers */ double dg_1pass, dg_2pass; int ig_pass_int; long ng_pass_long; /* for getting screen input from tsub_inp79 */ char sg_inp79[80]; int ig_inp79_lg; long ng_inp79_long; /* for getting screen input from tsub_inp1024 */ char sg_inp1024[1026]; int ig_inp1024_lg; /* link globals int iga_links[PLINES]; */ int iga_links[PLINES]; int ig_link_ix; int iga_subr_links[100]; int ig_subr_ix; int iga_var_link1[PLINES]; int iga_var_link2[PLINES]; /* variable stacks for global/local and variables below */ int ig_dvstack_ct, ig_svstack_ct; int ig_dvstack_ix, ig_svstack_ix; int iga_dvstack[VSTACK], iga_svstack[VSTACK]; int ig_dmaxglobal_ct, ig_smaxglobal_ct; int ig_dmaxliteral_ct, ig_smaxliteral_ct; /* debug variables ig_debug below */ int ig_debug; char sg_subr[70]; int ig_exit; /* global variables are above */ int main(int ip_argc, char *psp_argv[]) { /* updated 2011/09/26 */ /* 2010/06/18, 2010/06/12, 2010/06/04, 2010/04/15, 2009/01/25 */ /* 2008/02/22, 2007/02/24, 2006/11/07, 2006/08/09, 2005/11/05 */ /* 2005/10/07, 2005/08/02, 2005/06/14, 2005/05/19, 2005/04/27 */ /* 2005/04/24, 2005/04/09, 2005/04/02, 2005/03/28, 2005/03/27 */ /* 2005/03/12, 2005/03/05, 2005/02/24, 2005/02/08, 2004/11/29 */ int i_loop, iz; char s_action[80]; char sz[80]; if(ip_argc > 0) { /* get path from psp_argv */ ig_path = tfnn_string_char_search(psp_argv[0], 79, 0); tsub_copy(sg_path, psp_argv[0], ig_path); sg_path[ig_path] = 0; printf("path=%s\n", sg_path); } /* seed the random number function */ srand((unsigned int)(time(NULL))); tsub_line_of_char(sz, '-', 79); tsub_out79(sz, 79); tsub_copy(sg_version, "c90tea.cpp build=619 2014/03/05 ", 34); puts(sg_version); puts("c90tea.cpp copyright (c) 2004-2014 D La Pierre Ballard"); puts("c90tea.cpp written in C90 by D La Pierre Ballard 2004-2014"); puts("email: dlb@teapro.com."); puts("c90tea.cpp is the C90 source code for an interpreter"); puts("of the teapro programming language"); puts("the teapro programming language copyright (c) 1997-2014"); puts("by D La Pierre Ballard"); tsub_line_of_char(sz, '-', 79); tsub_out79(sz, 79); puts("the computer program source code c90tea.cpp may be used"); puts("for free by anyone, but there is no warranty"); puts("of any kind whatsoever on c90tea.cpp."); tsub_line_of_char(sz, '-', 79); tsub_out79(sz, 79); puts("the opentea technology makes teapro simple and solid"); tsub_line_of_char(sz, '-', 79); tsub_out79(sz, 79); puts("People need computer software that actually works."); tsub_line_of_char(sz, '-', 79); tsub_out79(sz, 79); ig_debug = 2; i_loop = 1; if(ip_argc > 1) { /* load and run program on command line */ tsub_blank(sg_loadprogram, 80); ig_loadprogram = tfnn_string_char_search(psp_argv[1], 79, 0); tsub_copy(sg_loadprogram, psp_argv[1], ig_loadprogram); sg_loadprogram[ig_loadprogram] = 0; sub_program_load(2); sub_program_run(); i_loop++; } while(i_loop == 1) { puts("c90tea.cpp console actions follow:"); puts("help, info, load, run, show, debug"); tsub_line_of_char(sz, '-', 79); tsub_out79(sz, 79); if(ig_debug == 1) puts("debug on"); else puts("debug off"); puts("* to end"); tsub_inp79(); tsub_copy(s_action, sg_inp79, ig_inp79_lg); tsub_case_upper(s_action, 79); if(s_action[0] == '*') i_loop++; if(tfni_compare_strings(s_action, "HELP", 4) == 0) sub_program_help(); if(tfni_compare_strings(s_action, "LOAD", 4) == 0) sub_program_load(1); if(tfni_compare_strings(s_action, "INFO", 4) == 0) sub_program_info(); if(tfni_compare_strings(s_action, "RUN", 3) == 0) { sub_program_run(); i_loop++; } if(tfni_compare_strings(s_action, "SHOW", 4) == 0) sub_program_show(); if(tfni_compare_strings(s_action, "DEBUG", 5) == 0) { if(ig_debug == 1) ig_debug++; else ig_debug = 1; } tsub_blank(s_action, 80); } /* free the memory of psga_plines */ for(iz = 0; iz < PLINES; iz++) { free(psga_plines[iz]); psga_plines[iz] = NULL; iga_plines_lg[iz] = 0; } /* free memory of psga_strings */ for(iz = 0; iz < VSTRINGS; iz++) { free(psga_strings[iz]); psga_strings[iz] = NULL; nga_strings_lg[iz] = 0; } /* free memory of psga_sarray */ for(iz = 0; iz < SARRAY; iz++) { free(psga_sarray[iz]); psga_sarray[iz] = NULL; iga_sarray_lg[iz] = 0; } return 0; } /* main */ void sub_program_help(void) { /* updated 2012/12/29, 2011/09/26, 2011/09/07 */ /* 2011/05/10, 2010/06/04, 2010/05/08, 2010/04/15, 2010/02/25 */ /* 2009/09/05, 2008/12/06, 2008/01/23, 2007/12/14, 2007/09/20 */ /* 2007/07/08, 2007/05/04, 2007/04/11, 2007/04/10, 2007/03/19 */ /* 2007/03/17, 2007/02/24, 2007/01/14, 2007/01/08, 2006/12/01 */ /* 2006/11/14, 2006/11/11, 2006/11/10, 2006/11/08, 2006/11/07 */ char s_dashes[75]; int i_good; i_good = 1; tsub_line_of_char(s_dashes, '-', 75); if(i_good == 1) { puts(s_dashes); puts("Teapro Commands"); puts(s_dashes); puts("ARRB"); puts("Blank string array of strings ranging from 1 to 2000."); puts(s_dashes); puts("$APP s_appto, s_appwith"); puts("Append string s_appwith to the end of string s_appto."); puts(s_dashes); puts("$BAK d_where, s_lookin, d_start, s_lookfor"); puts("Backward lookup in s_lookin for s_lookfor starting at"); puts("d_start. If found put first byte in d_where or zero if not."); puts(s_dashes); puts("$BES s_new, s_old"); puts("Blank escapes in s_old and put into s_new."); puts(s_dashes); puts("$CH$ s_new, s_char, d_long"); puts("Make string of characters s_new of length d_long"); puts("of first char of s_char."); puts(s_dashes); puts("$CHD d_char, s_char"); puts("Put decimal value of first char of s_char into d_char."); puts(s_dashes); tsub_inp79(); if(sg_inp79[0] == '*') i_good++; } if(i_good == 1) { puts("$CLO s_new, s_old"); puts("Make s_old lower case and put into s_new."); puts(s_dashes); puts("$CNT d_count, s_string, s_find"); puts("Put count of occurrences of s_find in s_string into d_count."); puts(s_dashes); puts("$COD s_new, s_old"); puts("Code or decode s_old into s_new. Code and decode are the same."); puts(s_dashes); puts("$CUP s_new, s_old"); puts("Make s_old uppercase and put into s_new."); puts(s_dashes); puts("$CUT s_part, s_whole, d_beg, d_long"); puts("Cut s_part from s_whole beginning at d_beg for length d_long."); puts(s_dashes); puts("$DAT s_date"); puts("Put date and time into s_date: 22-MAR-2002 21:28:16 20020322212816."); puts(s_dashes); puts("$DEL s_string, d_beg, d_long"); puts("Starting at d_beg delete d_long bytes from s_string."); puts(s_dashes); tsub_inp79(); if(sg_inp79[0] == '*') i_good++; } if(i_good == 1) { puts("$DOT d_where, s_whole, s_part, d_which"); puts("Put location of d_which occurrence of s_part in s_whole."); puts(s_dashes); puts("$HSH d_hash, s_string"); puts("Put a hash number for s_string into d_hash."); puts(s_dashes); puts("$IFT s_str1 >= s_str2"); puts("If string compare is true do all lines down to ELSE or ENDI."); puts(s_dashes); puts("$IFT s_str1 >= s_str2: d_any = d_dot"); puts("If string compare is true do statement to right of colon."); puts(s_dashes); puts("$INP s_input, s_output"); puts("Output s_output and recieve terminal input into s_input."); puts(s_dashes); puts("$INS s_insertinto, d_where, s_insertstr"); puts("Insert s_insertstr into s_insertinto beginning at d_where."); puts(s_dashes); puts("$ISC d_yesno, s_whole, s_char"); puts("If s_whole is a string of the first char of s_char"); puts("put 1 into d_yesno else 2."); puts(s_dashes); tsub_inp79(); if(sg_inp79[0] == '*') i_good++; } if(i_good == 1) { puts("$ISD d_yesno, s_number"); puts("If s_number can be converted to a decimal put 1 in d_yesno else 2."); puts(s_dashes); puts("$ISP d_yesno, s_string, s_pattern"); puts("If s_string is same pattern as s_pattern put 1 in d_yesno else 2."); puts("Patterns: escapes,blanks,punctuation,numbers,uppers,lowers,>126."); puts(s_dashes); puts("$IST d_yesno, s_string, s_type"); puts("If s_string is same type as first char of s_type put 1 in d_yesno"); puts("Types: escapes,blanks,punctuation,numbers,uppers,lowers,>126."); puts(s_dashes); puts("$LEN d_long, s_string"); puts("Put length of s_string into d_long."); puts(s_dashes); puts("$LOK d_where, s_lookin, d_start, s_lookfor"); puts("Lookup in s_lookin for s_lookfor starting at d_start."); puts("If found put first byte in d_where or zero if not."); puts(s_dashes); puts("$OFF s_end, s_string, d_long"); puts("Cut s_end off of end of s_string for length d_long."); puts(s_dashes); puts("$OUT s_output"); puts("Output s_output to the terminal."); puts(s_dashes); tsub_inp79(); if(sg_inp79[0] == '*') i_good++; } if(i_good == 1) { puts("$PAR s_part, s_whole, s_char, d_which"); puts("Parse s_whole which is a char separated value string to get"); puts("s_part which is occurrence d_which. The first char of s_char"); puts("separates the string s_whole."); puts(s_dashes); puts("$PKD d_yesno, d_decimal, s_packednumber"); puts("Change packed number in BCD to d_decimal. Put 1 in d_yesno if good."); puts(s_dashes); puts(s_dashes); puts("$REP s_whole, d_beg, s_part"); puts("In s_whole replace with s_part beginning at d_beg."); puts(s_dashes); puts("$SET s_assignto = s_string1 + \"ABC\" + d_number + #\"hello\"#"); puts("Set s_assignto equal to a string expression. $SET is not needed."); puts(s_dashes); puts("$SHO s_output"); puts("Output to the terminal s_output without a new line at the end."); puts(s_dashes); puts("$SOR s_new, s_old, d_elementlength"); puts("Sort s_old using d_elementlength into s_new."); puts(s_dashes); puts("$SWP s_swapin, s_oldpart, s_newpart"); puts("In s_swapin replace occurrences of s_oldpart with s_newpart."); puts(s_dashes); tsub_inp79(); if(sg_inp79[0] == '*') i_good++; } if(i_good == 1) { puts("$SYS s_systeminfo, d_which"); puts("If d_which=1 get path and filename of this Teapro interpreter."); puts("If d_which=2 get current Teapro subroutine name."); puts("If d_which=3 get version of current Teapro program."); puts("if d_which=4 get load program name."); puts(s_dashes); puts("$TLO s_new, s_old"); puts("Trim and lowercase s_old into s_new."); puts(s_dashes); puts("$TOD d_number, s_number"); puts("Change s_number to decimal and put in d_number."); puts(s_dashes); puts("$TOE s_oldtoe, s_string, s_key, d_which"); puts("Encode or decode s_string into s_oldtoe using s_key."); puts("If d_which=1 encode, if d_which=2 decode."); puts(s_dashes); puts("$TOI d_index, s_string"); puts("Put s_string in string array at index d_index, 1 to 2000 range."); puts(s_dashes); puts("$TRB s_new, s_old"); puts("Trim s_old on right and left and put into s_new."); puts(s_dashes); puts("$TRL s_new, s_old"); puts("Trim left s_old and put into s_new."); puts(s_dashes); tsub_inp79(); if(sg_inp79[0] == '*') i_good++; } if(i_good == 1) { puts("$TRR s_new, s_old"); puts("Trim right s_old and put into s_new."); puts(s_dashes); puts("$TUP s_new, s_old"); puts("Trim both and uppercase s_old and put into s_new."); puts(s_dashes); puts("$WHI s_string1 <= s_string2"); puts("If string compare is true do all lines downto ENDW."); puts(s_dashes); puts("ITO$ s_new, d_index"); puts("Get from string array at d_index, range 1 to 2000, into s_new."); puts(s_dashes); tsub_inp79(); if(sg_inp79[0] == '*') i_good++; } if(i_good == 1) { puts("Teapro decimal commands"); puts(s_dashes); puts("ADDI d_arrayindex, d_addtoelement"); puts(s_dashes); puts("ARRZ"); puts("Zero elements of decimal array 1..99000."); puts(s_dashes); puts("DABS d_new, d_number"); puts("Put absolute value of d_number into d_new."); puts(s_dashes); tsub_inp79(); if(sg_inp79[0] == '*') i_good++; } if(i_good == 1) { puts("DARC d_radians, d_sine"); puts("For sine d_sine put angle in radians in d_radians."); puts(s_dashes); puts("DBAD d_number1 >= d_number2"); puts("If numeric condition is true then bad and end program."); puts(s_dashes); puts("DBUG"); puts("Debug to look at variables etc."); puts(s_dashes); puts("DCH$ s_stringofchars, d_char, d_howmany"); puts(s_dashes); puts("DCUT d_result, s_string, d_begin, d_long"); puts("Cut number from s_string beginning at d_begin for d_long"); puts("put it into d_result."); puts(s_dashes); puts("DDEC d_number"); puts("Decrement decimal in d_number."); puts(s_dashes); puts("DDUO d_factor, d_number, d_mult"); puts("Factor of possible duo beginning at (d_number + d_mult * 1E15)."); puts("If the factor is 1 then the duo is a prime duo."); puts(s_dashes); puts("DED$ s_number, d_number, d_long, d_decimals"); puts("Edit d_number with dashes into s_number."); puts(s_dashes); puts("DFAC d_factor, d_number"); puts("Find factor of d_number, d_number is prime if factor is 1."); puts(s_dashes); tsub_inp79(); if(sg_inp79[0] == '*') i_good++; } if(i_good == 1) { puts("DFAK d_factor, d_number, d_mult"); puts("Find factor of (d_number + d_mult * 1E15)."); puts("If the factor is 1 then the expression value is prime."); puts(s_dashes); puts("DIFT d_number1 <= d_number2"); puts(s_dashes); puts("DINC d_number"); puts("Increment d_number by 1."); puts(s_dashes); puts("DLOG d_base10logarithm, d_number"); puts(s_dashes); puts("DPK$ s_packednumber, d_number, d_long"); puts(s_dashes); puts("DPOW d_result, d_number, d_power"); puts("d_result = d_number ^ d_power"); puts("Raise d_number to power d_power and put into d_result."); puts("DPOW works exactly the same as using ^ in the decimal assignment."); puts(s_dashes); puts("DRAN d_random"); puts("Put a positive random decimal less than 1 into d_random."); puts(s_dashes); tsub_inp79(); if(sg_inp79[0] == '*') i_good++; } if(i_good == 1) { puts("DROU d_rounded, d_number"); puts("Round d_number to a whole number into d_rounded."); puts(s_dashes); puts("DSEC d_seconds"); puts("Put number of seconds into d_seconds."); puts(s_dashes); puts("DSIN d_sine, d_radians"); puts("Put the sine of d_radians into d_sine."); puts(s_dashes); puts("DSET d_result = -2.5 ? 2 * d_num1 - d_num2 \\ 4 / d_num3 + 0.5 @ 2 ^ 2"); puts("DSET the decimal expression assignment command."); puts("The command DSET may be left out."); puts(s_dashes); puts("DSET operators"); puts("+ is add, - is subtract, * is multiply, / is divide, % is mod."); puts("\\ is integer divide, @ 2 is round to 2, ? 2 is truncate to 2."); puts("^ is exponentiate."); puts(s_dashes); puts("DSYS d_system, d_which"); puts("d_which=1 gives total variable and array sting length"); puts("d_which=2 gives program lines done"); puts("d_which=3 gives total lines in loaded program"); puts(s_dashes); puts("DTO$ s_number, d_number, d_long, d_decimals"); puts("Change d_number to string s_number with no commas."); puts(s_dashes); puts("DTOF s_field, d_number, d_long"); puts("Change d_number to a field number s_field with length d_long."); puts(s_dashes); tsub_inp79(); if(sg_inp79[0] == '*') i_good++; } if(i_good == 1) { puts("DTOI d_index, d_number"); puts("Put d_number into the 99000 element array at d_index"); puts(s_dashes); puts("DTRU d_truncated, d_number"); puts("Truncate d_number towards zero to an integer"); puts(s_dashes); puts("DWHI d_number1 <= d_number2"); puts(s_dashes); puts("ITOD d_number, d_index"); puts("Put decimal from 99000 element array at d_index into d_number"); puts(s_dashes); tsub_inp79(); if(sg_inp79[0] == '*') i_good++; } if(i_good == 1) { puts("ELSE"); puts("Else in a DIFT or $IFT if block"); puts(s_dashes); puts("ENDI"); puts("End of DIFT or $IFT if block"); puts(s_dashes); puts("ENDP"); puts("Ends program"); puts(s_dashes); puts("ENDW"); puts("Ends DWHI or $WHI while loops"); puts(s_dashes); puts("GTAG tag_loop1"); puts("GOTO tag_loop1"); puts("GOTO the tag GTAG with the same tag name."); puts("GOTO cannot jump into or outof a subroutine."); puts(s_dashes); puts("SUBR sub_some_subroutine"); puts("Begins a subroutine sub_some_subroutine"); puts(s_dashes); puts("ENDS sub_some_subroutine"); puts("Ends a subroutine sub_some_subroutine"); puts(s_dashes); puts("VARI d_number, s_string"); puts("Defines local decimal variable d_number and"); puts("defines local string variable s_string"); puts(s_dashes); tsub_inp79(); if(sg_inp79[0] == '*') i_good++; } if(i_good == 1) { puts("FADD d_long, s_filename, s_record"); puts("Append s_record to file s_filename put length in d_long."); puts("This command puts a linefeed on the end of the record."); puts(s_dashes); puts("FAPP d_long, s_filename, s_record"); puts("Append s_record to file s_filename put length in d_long."); puts("This command puts a carriage return and line feed on."); puts(s_dashes); puts("FDEL d_result, s_filename"); puts("Delete file s_filename put 1 in d_result."); puts(s_dashes); puts("FINP s_wholefile, s_filename"); puts("Input whole file s_filename into s_wholefile."); puts(s_dashes); puts("FLEN d_long, s_filename"); puts("Put length of file s_filename into d_long."); puts(s_dashes); tsub_inp79(); if(sg_inp79[0] == '*') i_good++; } if(i_good == 1) { puts("FOUT d_length, s_outfilename, s_wholefile"); puts("Output s_wholefile to s_outfilename put length in d_length."); puts(s_dashes); puts("FREA s_record, s_filename, d_byte, d_long"); puts("Read file s_filename beginning at d_byte for d_long into s_record."); puts(s_dashes); puts("FREN s_newfilename, s_oldfilename"); puts("Rename file s_oldfilename to file s_newfilename."); puts(s_dashes); puts("FSIP s_record, s_filename, d_filebyte"); puts("Sip s_record from s_filename beginning at d_filebyte and"); puts("beginning of next record in d_filebyte."); puts(s_dashes); puts("FWRI d_long, s_filename, d_byte, s_record"); puts("Write s_record to s_filename at d_byte put length in d_long."); puts(s_dashes); tsub_inp79(); } } /* sub_program_help */ void sub_program_load(int ip_mode) { /* updated 2010/04/15, 2008/02/20, 2007/10/13, 2005/12/02, 2005/11/30 */ /* 2005/10/29, 2005/09/03, 2005/06/18, 2005/06/14, 2005/06/01 */ /* 2005/04/30, 2005/04/14, 2005/04/04, 2005/04/01, 2005/03/29 */ /* 2005/03/14, 2005/03/12, 2005/03/01, 2005/02/19, 2005/02/13 */ /* 2005/02/08, 2005/02/06, 2005/01/31, 2005/01/30, 2004/12/18 */ FILE *pf_program; char s_record[200]; char s_pline[200]; char s_vars_str[VCHARNAME]; int i_vars_str_lg; char s_vars_dec[VCHARNAME]; int i_vars_dec_lg; char s_split[200]; int i_split_lg; char *psz; int i_process, i_good, i_loop, i_read_record, i_colon; int i_type, i_subrline, i_insubr, i_newsubr, i_first_not_vari_hit; int iy, iz; /* zero max global and stored literal counts */ ig_dmaxglobal_ct = 0; ig_smaxglobal_ct = 0; ig_dmaxliteral_ct = 0; ig_smaxliteral_ct = 0; tsub_blank(s_vars_str, VCHARNAME); i_vars_str_lg = 0; tsub_blank(s_vars_dec, VCHARNAME); i_vars_dec_lg = 0; if(ip_mode == 1) { /* begin load from the menu */ puts("enter program name"); tsub_inp79(); tsub_copy(sg_loadprogram, sg_inp79, ig_inp79_lg); sg_loadprogram[ig_inp79_lg] = 0; ig_loadprogram = ig_inp79_lg; } /* open the file */ i_process = 1; pf_program = fopen(sg_loadprogram, "r"); if(pf_program == NULL) { puts("file not opened"); i_process++; tsub_inp79(); } /* initial psga_plines pointers to NULL */ if(i_process == 1) { for(iz = 0; iz < PLINES; iz++) { free(psga_plines[iz]); psga_plines[iz] = NULL; iga_plines_lg[iz] = 0; } sub_program_initialize(1); } /* get program plines from file */ ig_exit = 2; i_first_not_vari_hit = 2; i_split_lg = 0; i_read_record = 1; i_insubr = 2; i_newsubr = 1; ig_pline_ix = 0; i_loop = i_process; while(i_loop == 1) { i_good = 1; tsub_blank(s_record, 200); if(i_read_record == 1) { /* read record in from program file */ psz = fgets(s_record, sizeof(s_record), pf_program); if(psz == NULL) { i_loop++; i_good++; } } else { /* last part of a split */ tsub_copy(s_record, s_split, i_split_lg); i_read_record = 1; } if(i_good == 1) { tsub_copy(sg_pass, s_record, 200); tsub_blank_escapes(sg_pass, VSLONG); ng_pass_lg = 200; tsub_pass_trim_right(); tsub_pass_trim_left(); tsub_blank(sg_pline, 200); tsub_copy(sg_pline, sg_pass, ng_pass_lg); ig_pline_lg = ng_pass_lg; if(sg_pline[0] <= 32) i_good++; if(sg_pline[0] == '\'') i_good++; if(sg_pline[0] == '<') i_good++; } if(i_good == 1) { /* do we have a split record */ sub_prep_split(&i_colon); if(i_colon > 0) { /* we have a split */ i_read_record = 2; i_split_lg = ig_pline_lg - i_colon; tsub_copy(s_split, &sg_pline[i_colon + 1], i_split_lg); ig_pline_lg = i_colon; tsub_case_upper(sg_pline, 4); iz = tfni_compare_strings(sg_pline, "DIFT", 4); if(iz == 0) sg_pline[3] = '1'; iz = tfni_compare_strings(sg_pline, "$IFT", 4); if(iz == 0) sg_pline[3] = '1'; } } if(i_good == 1) { //if(ig_pline_ix > 16288 && ig_pline_ix < 16295) puts(sg_pline); /* store string literals */ sub_prep_literal_strings(); /* remove not needed spaces in sg_pline,ig_pline_lg */ sub_prep_no_spaces(); /* make unquoted upper case */ tsub_case_upper(sg_pline, ig_pline_lg); /* store number literals */ sub_prep_literal_numbers(); //if(ig_pline_ix > 16288 && ig_pline_ix < 16295) puts(sg_pline); /* do we have a subr line ie SUBR,SUB_ set i_subrline */ iz = tfni_compare_strings(sg_pline, "SUBR", 4); if(iz != 0) iz = tfni_compare_strings(sg_pline, "SUB_", 4); if(iz == 0) i_subrline = 1; else i_subrline = 2; /* prep the format of the sg_pline,ig_pline_ig */ /* put in DSET,$SET,ESUB */ sub_prep_format1(); //if(ig_pline_ix > 16288 && ig_pline_ix < 16295) puts(sg_pline); /* prep variables in the pline */ if(i_subrline != 1) { /* ENDS has to run through these */ sub_prep_variables_str(s_vars_str, &i_vars_str_lg); if(i_vars_str_lg > VCHARNAME) { sub_program_error_end("too many str", 12); i_vars_str_lg = 1; } sub_prep_variables_dec(s_vars_dec, &i_vars_dec_lg); if(i_vars_str_lg > VCHARNAME) { sub_program_error_end("too many dec", 12); i_vars_str_lg = 1; } } /* prep the format of the sg_pline,ig_pline_ig */ /* put + in DSET and make compare two bytes in DIFT,$IFT */ sub_prep_format2(); //if(ig_pline_ix > 16288 && ig_pline_ix < 16295) puts(sg_pline); /* 1=SUBR, 2=VARI */ i_type = 0; /* i_insubr=1 means we are in a subroutine */ iz = tfni_compare_strings(sg_pline, "SUBR,", 5); if(iz == 0) { i_insubr = 1; i_newsubr = 1; i_type = 1; } iz = tfni_compare_strings(sg_pline, "VARI,", 5); if(iz == 0) i_type = 2; if(i_newsubr == 1 && i_type == 0) { /* we need an EVAR line: EVAR,N00000,N00000; */ tsub_copy(s_pline, "EVAR,N00000,N00000;", 19); sub_prep_evar(i_insubr, s_pline, s_vars_dec, i_vars_dec_lg); sub_prep_evar(i_insubr, s_pline, s_vars_str, i_vars_str_lg); tsub_make_long_string(&psga_plines[ig_pline_ix], 19); tsub_copy(psga_plines[ig_pline_ix], s_pline, 19); iga_plines_lg[ig_pline_ix] = 19; i_newsubr++; ig_pline_ix++; } if(i_first_not_vari_hit != 1 && i_type != 2) { /* first not vari so have all globals */ i_first_not_vari_hit = 1; iy = 0; for(iz = 0; iz < i_vars_dec_lg; iz++) { if(s_vars_dec[iz] == ':') iy++; } ig_dmaxglobal_ct = iy; iy = 0; for(iz = 0; iz < i_vars_str_lg; iz++) { if(s_vars_str[iz] == ':') iy++; } ig_smaxglobal_ct = iy; if(ig_debug == 1) { printf("ig_dmaxglobal_ct=%d, ig_smaxglobal_ct=%d\n", ig_dmaxglobal_ct, ig_smaxglobal_ct); tsub_inp79(); } } /* allocate space and store the pline */ tsub_make_long_string(&psga_plines[ig_pline_ix], ig_pline_lg); tsub_copy(psga_plines[ig_pline_ix], sg_pline, ig_pline_lg); iga_plines_lg[ig_pline_ix] = ig_pline_lg; if(ig_debug == 1) { tsub_show_pline_by_index(ig_pline_ix); } /* tsub_show_pline(ig_pline_ix, sg_pline, ig_pline_lg); */ /* tell */ if((ig_pline_ix % 1000) == 0) printf("load=%d\r", ig_pline_ix); ig_pline_ix++; /* tell */ if((ig_pline_ix % 1000) == 0) printf("load=%d\r", ig_pline_ix); if(ig_pline_ix >= (PLINES - 20)) i_loop++; if(ig_exit == 1) i_loop++; } } /* prep the global/local variable stacks */ iy = ig_dmaxliteral_ct; iga_dvstack[0] = iy; ig_dvstack_ct = iy; ig_dvstack_ix = 0; iy = ig_smaxliteral_ct; iga_svstack[0] = iy; ig_svstack_ct = iy; ig_svstack_ix = 0; printf("lines=%d\n", --ig_pline_ix); ig_plines_total_count = ig_pline_ix; if(i_process == 1) fclose(pf_program); } /* sub_program_load */ void sub_program_show(void) { /* updated 2006/03/06, 2005/12/04 */ /* 2005/03/30, 2005/03/29, 2005/03/13, 2005/02/06, 2004/11/21 */ int i_loop, i_index, i_linect, i_subr, iz; FILE *pf_export; i_subr = 2; i_index = 0; i_linect = 0; i_loop = 1; while(i_loop == 1) { ig_pline_lg = iga_plines_lg[i_index]; tsub_copy(sg_pline, psga_plines[i_index], ig_pline_lg); if(ig_debug == 1) { printf("i_index=%d, i_long=%d\n", i_index, ig_pline_lg); i_linect++; } if(tfni_compare_strings(sg_pline, "SUBR", 4) == 0) { if(i_subr == 1) { tsub_show_pline(i_index, sg_pline, ig_pline_lg); } else { /* put a blank line above a SUBR */ puts(" "); } i_linect++; } if(i_subr != 1) { tsub_show_pline(i_index, sg_pline, ig_pline_lg); i_linect++; } i_index++; if(i_index >= PLINES) i_linect = 50; if(iga_plines_lg[i_index] == 0) i_linect = 50; if(i_linect == 50) i_index = 0; if(i_linect >= 22) { i_linect = 1; tsub_out79("return, line#, SUBR, NUM, EXP or * to end", 41); tsub_inp79(); /* toggle looking at just SUBR */ tsub_case_upper(sg_inp79, 79); iz = tfni_compare_strings(sg_inp79, "SUBR", 4); if(iz == 0) { if(i_subr != 1) i_subr = 1; else i_subr = 2; } /* show numbers */ iz = tfni_compare_strings(sg_inp79, "NUM", 3); if(iz == 0) { printf(" ig_dmaxglobal_ct=%d\n", ig_dmaxglobal_ct); printf("ig_dmaxliteral_ct=%d\n", ig_dmaxliteral_ct); printf(" ig_smaxglobal_ct=%d\n", ig_smaxglobal_ct); printf("ig_smaxliteral_ct=%d\n", ig_smaxliteral_ct); tsub_inp79(); } iz = tfni_compare_strings(sg_inp79, "EXP", 3); if(iz == 0) { puts("1=export to file export1.txt"); tsub_inp79(); if(sg_inp79[0] == '1') { pf_export = fopen("export1.txt", "w"); if(pf_export != NULL) { for(iz = 0; iz <= PLINES && iga_plines_lg[iz] != 0; iz++) { ig_pline_lg = iga_plines_lg[iz]; tsub_copy(sg_pline, psga_plines[iz], ig_pline_lg); sg_pline[ig_pline_lg] = 0; fprintf(pf_export, "%s\n", sg_pline); } fclose(pf_export); } } } if(sg_inp79[0] == '*') i_loop++; if(ng_inp79_long > 0) { i_index = ng_inp79_long - 1; i_subr = 2; } if(i_index < 0 || i_index >= PLINES) i_index = 0; } } } /* sub_program_show */ void sub_program_run(void) { /* updated 2011/05/10 */ /* 2011/01/23, 2010/09/21, 2010/09/07, 2010/08/01, 2010/06/12 */ /* 2010/06/04, 2009/03/07, 2009/03/08, 2008/11/20, 2008/10/20 */ /* 2008/03/06, 2008/02/21, 2008/02/20, 2008/02/10, 2008/01/30 */ /* 2008/01/27, 2008/01/26, 2008/01/23, 2008/01/16, 2007/10/15 */ /* 2006/10/26, 2006/09/26, 2006/09/25, 2006/09/24, 2006/05/31 */ /* 2006/05/12, 2006/04/29, 2006/04/23, 2006/03/17, 2006/03/11 */ /* 2006/01/17, 2005/11/30, 2005/09/18, 2005/09/04, 2005/09/03 */ /* 2005/08/05, 2005/07/26, 2005/06/20, 2005/05/09, 2005/05/03 */ /* 2005/04/12, 2005/04/09, 2005/04/06, 2005/04/02, 2005/03/31 */ /* 2005/03/27, 2005/03/25, 2005/03/19, 2005/03/14, 2005/03/13 */ /* 2005/03/12, 2005/03/06, 2005/03/05, 2005/03/01, 2005/02/27 */ /* 2005/02/26, 2005/02/24, 2005/02/21, 2005/02/20, 2005/02/17 */ /* 2005/02/13, 2005/02/06, 2005/02/03, 2005/01/30, 2004/12/11 */ int i_command; long n_index; ig_exit = 2; if(ig_debug == 1) tsub_bug("sub_program_run"); sub_program_initialize(2); if(ig_debug == 1) tsub_bug("sub_program_initialize(2)"); /* link commands parm1,parm2 to iga_var_link1,iga_var_link2 */ sub_program_link_var(); /* link dwhi,$whi,dift,$ift,else,endi,endw */ sub_program_link_dift_dwhi(); if(ig_debug == 1) tsub_bug("sub_program_link_dift_dwhi"); /* link esub to subr */ sub_program_link_esub(); if(ig_debug == 1) tsub_bug("sub_program_link_esub"); /* link the commands into iga_link_commands */ sub_program_link_commands(); if(ig_debug == 1) tsub_bug("sub_program_link_commands"); /* validate the commands and variables */ sub_program_validate_commands(); if(ig_exit != 1 && ig_debug == 1) { tsub_bug("sub_program_validate_commands"); } ig_pline_ix = -1; while(ig_exit != 1) { /* increment to the next line number */ ig_pline_ix++; /* dg_plines_done is how many lines were run */ dg_plines_done++; /* get the command number into i_command */ i_command = iga_link_commands[ig_pline_ix]; /* get the line sg_pline,ig_pline_lg from index ig_pline_ix */ /* ig_pline_lg = iga_plines_lg[ig_pline_ix]; */ /* tsub_copy(sg_pline, psga_plines[ig_pline_ix], ig_pline_lg); */ /* psg_pline = psga_plines[ig_pline_ix]; */ /* get the link for this line */ ig_link_ix = iga_links[ig_pline_ix]; /* DDEC,DDUO,DFAK,DFAC,DIFT,DINC, DRAN,DSEC,DSET,DTO$,DTOI,DWHI, ELSE,ENDI,ENDP,ENDS,ENDW,ESUB, EVAR,ITOD,$APP,$BES,$CHD,$CLO, $CUP,$CUT,$DAT,$DEL,$SHO,$IFT, $INP,$INS,$ISD,$LEN,$OUT,$REP, $SET,$TLO,$TOD,$TRB,$TRL,$TRR, $TUP,$WHI,FWRI,FREA,FAPP,FLEN, FDEL,FSIP,DBAD,DIF1,$IF1,$LOK, $BAK,$CH$,DCH$,$TOI,ITO$,$ISC, $IST,$ISP,$OFF,DBUG,FREN,$PAR, ARRB,ARRZ,$SYS,DABS,DROU,DTRU, $SWP,$SOR,$CNT,$PKD,DPK$,DTOF, FINP,FOUT,FADD,DSYS,VARI,SUBR, $COD,$TOE,DLOG,DSIN,DARC,ADDI, $DEL,$HSH,DED$,GTAG,GOTO,DPOW, DCUT 97 */ if(i_command < 13) { /* make psg_pline point to the command line */ psg_pline = psga_plines[ig_pline_ix]; if(i_command == 5) { /* DIFT,DWHI,DIF1 */ sub_command_dift_dwhi(); if(ig_true != 1) ig_pline_ix = ig_link_ix; } else if(i_command == 6) { /* DINC */ if(psg_pline[5] == 'E') n_index = ig_link_ix + ig_dvstack_ct; else n_index = ig_link_ix; dga_decimals[n_index]++; } else if(i_command == 9) { /* DSET */ /* get ig_pline_lg from index ig_pline_ix */ ig_pline_lg = iga_plines_lg[ig_pline_ix]; sub_command_dset(); /* DSET */ } else if(i_command == 1) sub_command_dinc(2); /* DDEC */ else if(i_command == 2) sub_command_dduo(); /* DDUO */ else if(i_command == 8) sub_command_dinc(3); /* DSEC */ else if(i_command == 3) sub_command_dfak(); /* DFAK */ else if(i_command == 4) sub_command_dfac(); /* DFAC */ else if(i_command == 7) sub_command_dinc(4); /* DRAN */ else if(i_command == 10) sub_command_dtos(1); /* DTOS */ else if(i_command == 11) sub_command_dtoi(1); /* DTOI */ else if(i_command == 12) sub_command_dcut(); /* DCUT */ } else if(i_command < 21) { if(i_command == 13) ig_pline_ix = ig_link_ix; /* ELSE,GOTO */ else if(i_command == 14); /* ENDI,GTAG */ else if(i_command == 17) { /* endw so change the line number to the link */ ig_pline_ix = ig_link_ix + 1; /* make psg_pline point to the command line */ psg_pline = psga_plines[ig_pline_ix]; if(iga_link_commands[ig_pline_ix] == 5) { /* DIFT,DWHI,DIF1 */ sub_command_dift_dwhi(); if(ig_true != 1) ig_pline_ix = iga_links[ig_pline_ix]; } else { /* $IFT and $IF1 and $WHI */ sub_command_sift_swhi(); if(ig_true != 1) ig_pline_ix = iga_links[ig_pline_ix]; } } else if(i_command == 20) { /* ITOD */ /* make psg_pline point to the command line */ psg_pline = psga_plines[ig_pline_ix]; sub_command_itod(); /* ITOD */ } else if(i_command == 16) sub_command_ends(); /* ENDS */ else if(i_command == 18) { /* ESUB */ ig_subr_ix++; iga_subr_links[ig_subr_ix] = ig_pline_ix; ig_pline_ix = ig_link_ix; } else if(i_command == 19) { /* EVAR */ /* make psg_pline point to the command line */ psg_pline = psga_plines[ig_pline_ix]; sub_command_evar(); /* EVAR */ } else if(i_command == 15) ig_exit = 1; /* ENDP */ } else if(i_command < 31) { /* make psg_pline point to the command line */ psg_pline = psga_plines[ig_pline_ix]; if(i_command == 30) { /* $IFT and $IF1 and $WHI */ sub_command_sift_swhi(); if(ig_true != 1) ig_pline_ix = ig_link_ix; } else if(i_command == 21) { /* $APP */ /* get ig_pline_lg from index ig_pline_ix */ ig_pline_lg = iga_plines_lg[ig_pline_ix]; sub_command_sapp(); /* $APP */ } else if(i_command == 22) sub_command_strl(4); /* $BES */ else if(i_command == 23) sub_command_slen(2); /* $CHD */ else if(i_command == 24) sub_command_strl(5); /* $CLO */ else if(i_command == 25) sub_command_strl(6); /* $CUP */ else if(i_command == 26) sub_command_scut(); /* $CUT */ else if(i_command == 27) sub_command_sdat(); /* $DAT */ else if(i_command == 28) sub_command_sdel(); /* $DEL */ else if(i_command == 29) { /* $SHO */ /* get ig_pline_lg from index ig_pline_ix */ ig_pline_lg = iga_plines_lg[ig_pline_ix]; sub_command_sout(2); /* $SHO */ } } else if(i_command < 41) { /* make psg_pline point to the command line */ psg_pline = psga_plines[ig_pline_ix]; if(i_command == 31) { /* $INP */ /* get ig_pline_lg from index ig_pline_ix */ ig_pline_lg = iga_plines_lg[ig_pline_ix]; sub_command_sinp(); /* $INP */ } else if(i_command == 32) sub_command_sins(); /* $INS */ else if(i_command == 33) sub_command_stod(2); /* $ISD */ else if(i_command == 34) sub_command_slen(1); /* $LEN */ else if(i_command == 35) { /* $OUT */ /* get ig_pline_lg from index ig_pline_ix */ ig_pline_lg = iga_plines_lg[ig_pline_ix]; sub_command_sout(1); /* $OUT */ } else if(i_command == 36) sub_command_srep(); /* $REP */ else if(i_command == 37) { /* $SET */ /* get ig_pline_lg from index ig_pline_ix */ ig_pline_lg = iga_plines_lg[ig_pline_ix]; sub_command_sset(); /* $SET */ } else if(i_command == 38) sub_command_strl(7); /* $TLO */ else if(i_command == 39) sub_command_stod(1); /* $TOD */ else if(i_command == 40) sub_command_strl(3); /* $TRB */ } else if(i_command < 51) { /* make psg_pline point to the command line */ psg_pline = psga_plines[ig_pline_ix]; if(i_command == 41) sub_command_strl(1); /* $TRL */ else if(i_command == 42) sub_command_strl(2); /* $TRR */ else if(i_command == 43) sub_command_strl(8); /* $TUP */ else if(i_command == 45) sub_command_file(1); /* FWRI */ else if(i_command == 46) sub_command_file(2); /* FREA */ else if(i_command == 47) sub_command_file(10); /* FAPP */ else if(i_command == 48) sub_command_file(4); /* FLEN */ else if(i_command == 49) sub_command_file(5); /* FDEL */ else if(i_command == 50) sub_command_file(6); /* FSIP */ else if(i_command == 44) { /* $WHI see $IFT=30 */ sub_command_sift_swhi(); if(ig_true != 1) ig_pline_ix = ig_link_ix; } } else if(i_command < 61) { /* make psg_pline point to the command line */ psg_pline = psga_plines[ig_pline_ix]; if(i_command == 51) { /* DBAD */ sub_command_dift_dwhi(); if(ig_true == 1) sub_command_dbad(); } else if(i_command == 54) sub_command_slok(1); /* $LOK */ else if(i_command == 55) sub_command_slok(2); /* $BAK */ else if(i_command == 56) sub_command_schs(1); /* $CH$ */ else if(i_command == 57) sub_command_schs(2); /* DCH$ */ else if(i_command == 58) sub_command_stoi(1); /* $TOI */ else if(i_command == 59) sub_command_stoi(2); /* ITO$ */ else if(i_command == 60) sub_command_sisc(1); /* $ISC */ else if(i_command == 52) { /* DIF1 same as DIFT=4 */ sub_command_dift_dwhi(); if(ig_true != 1) ig_pline_ix++; } else if(i_command == 53) { /* $IF1 same as $IFT=30 */ sub_command_sift_swhi(); if(ig_true != 1) ig_pline_ix++; } } else if(i_command < 71) { /* make psg_pline point to the command line */ psg_pline = psga_plines[ig_pline_ix]; if(i_command == 61) sub_command_sisc(2); /* $IST */ else if(i_command == 62) sub_command_sisc(3); /* $ISP */ else if(i_command == 63) sub_command_schs(3); /* $OFF */ else if(i_command == 64) sub_command_dbug(); /* DBUG */ else if(i_command == 65) sub_command_file(7); /* FREN */ else if(i_command == 66) sub_command_spar(); /* $PAR */ else if(i_command == 67) sub_command_stoi(3); /* ARRB */ else if(i_command == 68) sub_command_stoi(4); /* ARRZ */ else if(i_command == 69) sub_command_ssys(); /* $SYS */ else if(i_command == 70) sub_command_dabs(1); /* DABS */ } else if(i_command < 81) { /* make psg_pline point to the command line */ psg_pline = psga_plines[ig_pline_ix]; if(i_command == 71) sub_command_dabs(2); /* DROU */ else if(i_command == 72) sub_command_dabs(3); /* DTRU */ else if(i_command == 73) sub_command_sswp(); /* $SWP */ else if(i_command == 74) sub_command_ssor(); /* $SOR */ else if(i_command == 75) sub_command_scnt(); /* $CNT */ else if(i_command == 76) sub_command_spkd(1); /* $PKD */ else if(i_command == 77) sub_command_spkd(2); /* DPK$ */ else if(i_command == 78) sub_command_spkd(3); /* DTOF */ else if(i_command == 79) sub_command_file(8); /* FINP */ else if(i_command == 80) sub_command_file(9); /* FOUT */ } else if(i_command < 97) { /* make psg_pline point to the command line */ psg_pline = psga_plines[ig_pline_ix]; if(i_command == 81) sub_command_file(3); /* FADD */ else if(i_command == 82) sub_command_dsys(); /* dsys */ else if(i_command == 83); /* VARI */ /* else if(i_command == 84); SUBR would be an error */ else if(i_command == 85) sub_command_strl(9); /* $COD */ else if(i_command == 86) sub_command_stoe(); /* $TOE */ else if(i_command == 87) sub_command_dabs(4); /* DLOG */ else if(i_command == 88) sub_command_dabs(5); /* DSIN */ else if(i_command == 89) sub_command_dabs(6); /* DARC */ else if(i_command == 90) sub_command_dtoi(3); /* ADDI */ else if(i_command == 91) sub_command_sdot(); /* $DOT */ else if(i_command == 92) sub_command_slen(3); /* $HSH */ else if(i_command == 93) sub_command_dtos(2); /* DED$ */ else if(i_command == 94); /* GTAG see ENDI */ /* GOTO see ELSE */ else if(i_command == 95) ig_pline_ix = ig_link_ix; else if(i_command == 96) sub_command_dpow(); /* DPOW */ } else { /* we have a not known command */ sub_command_dbug(); tsub_out79("bad command at run", 18); tsub_inp79(); ig_exit = 1; } } } /* sub_program_run */ void sub_program_info(void) { /* updated 2005/06/07 */ /* 2005/05/29, 2005/04/14, 2005/04/06, 2005/03/14, 2005/03/12 */ /* 2005/03/03, 2005/02/24, 2005/02/15, 2005/02/01, 2004/11/26 */ printf("plines=%d\n", PLINES); printf("pstack=%d\n", PSTACK); printf("vstrings=%d\n", VSTRINGS); printf("vslong=%d\n", VSLONG); printf("vdeciamls=%d\n", VDECIMALS); printf("vstack=%d\n", VSTACK); printf("darray=%d\n", DARRAY); printf("sarray=%d\n", SARRAY); printf("max new string length=%d\n", MAXSTRING); printf("lines run=%.0f\n", dg_plines_done); tsub_inp79(); } /* sub_program_info */ void sub_program_initialize(int ip_which) { /* updated 2005/12/02, 2005/06/05, 2005/05/09 */ /* 2005/04/06, 2005/03/12, 2005/02/24, 2005/02/01, 2004/11/25 */ int iz; /* dg_plines_done is how many lines were run */ dg_plines_done = 0; ig_subr_ix = 0; if(ip_which == 1) { for(iz = 0; iz < VSTRINGS; iz++) { free(psga_strings[iz]); psga_strings[iz] = NULL; nga_strings_lg[iz] = 0; } for(iz = 0; iz < VDECIMALS; iz++) { dga_decimals[iz] = 0; } } for(iz = 0; iz < 100; iz++) { iga_subr_links[iz] = 0; } ig_dvstack_ix = 0; ig_svstack_ix = 0; if(ip_which == 1) { for(iz = 0; iz < VSTACK; iz++) { iga_dvstack[iz] = 0; iga_svstack[iz] = 0; } } for(iz = 0; iz < DARRAY; iz++) dga_darray[iz] = 0; for(iz = 0; iz < SARRAY; iz++) { free(psga_sarray[iz]); psga_sarray[iz] = NULL; iga_sarray_lg[iz] = 0; } free(psg_use1); psg_use1 = NULL; ng_use1 = 0; free(psg_use2); psg_use2 = NULL; ng_use2 = 0; free(psg_use3); psg_use3 = NULL; ng_use3 = 0; } /* sub_program_initialize */ void sub_program_link_commands(void) { /* updated 2010/09/21 */ /* 2010/09/07, 2010/08/01, 2008/12/06, 2008/10/20, 2008/01/30 */ /* 2008/01/23, 2007/04/17, 2007/04/10, 2006/10/26, 2006/05/31 */ /* 2006/05/12, 2006/04/29, 2006/04/23, 2006/03/17, 2006/01/17 */ /* 2005/09/18, 2005/07/27, 2005/06/20, 2005/05/09, 2005/05/05 */ /* 2005/05/03, 2005/04/12, 2005/04/03, 2005/04/02, 2005/03/31 */ /* 2005/03/30, 2005/03/27, 2005/03/25, 2005/03/19, 2005/03/13 */ /* 2005/03/12, 2005/03/06, 2005/03/05, 2005/03/01, 2005/02/26 */ int i_loop, i_command, iz; char s_commands[500]; for(iz = 0; iz < PLINES; iz++) iga_link_commands[iz] = 9999; tsub_blank(s_commands, 500); /* DDEC,DDUO,DFAK,DFAC,DIFT,DINC, DRAN,DSEC,DSET,DTO$,DTOI,DWHI, ELSE,ENDI,ENDP,ENDS,ENDW,ESUB, EVAR,ITOD,$APP,$BES,$CHD,$CLO, $CUP,$CUT,$DAT,$DEL,$SHO,$IFT, $INP,$INS,$ISD,$LEN,$OUT,$REP, $SET,$TLO,$TOD,$TRB,$TRL,$TRR, $TUP,$WHI,FWRI,FREA,FAPP,FLEN, FDEL,FSIP,DBAD,DIF1,$IF1,$LOK, $BAK,$CH$,DCH$,$TOI,ITO$,$ISC, $IST,$ISP,$OFF,DBUG,FREN,$PAR, ARRB,ARRZ,$SYS,DABS,DROU,DTRU, $SWP,$SOR,$CNT,$PKD,DPK$,DTOF, FINP,FOUT,FADD,DSYS,VARI,SUBR, $COD,$TOE,DLOG,DSIN,DARC,ADDI, $DOT,$HSH,DED$,GTAG,GOTO,DPOW, DCUT 97 */ tsub_copy(s_commands, "DDEC,DDUO,DFAK,DFAC,DIFT,DINC,", 30); tsub_copy(&s_commands[30], "DRAN,DSEC,DSET,DTO$,DTOI,DWHI,", 30); tsub_copy(&s_commands[60], "ELSE,ENDI,ENDP,ENDS,ENDW,ESUB,", 30); tsub_copy(&s_commands[90], "EVAR,ITOD,$APP,$BES,$CHD,$CLO,", 30); tsub_copy(&s_commands[120], "$CUP,$CUT,$DAT,$DEL,$SHO,$IFT,", 30); tsub_copy(&s_commands[150], "$INP,$INS,$ISD,$LEN,$OUT,$REP,", 30); tsub_copy(&s_commands[180], "$SET,$TLO,$TOD,$TRB,$TRL,$TRR,", 30); tsub_copy(&s_commands[210], "$TUP,$WHI,FWRI,FREA,FAPP,FLEN,", 30); tsub_copy(&s_commands[240], "FDEL,FSIP,DBAD,DIF1,$IF1,$LOK,", 30); tsub_copy(&s_commands[270], "$BAK,$CH$,DCH$,$TOI,ITO$,$ISC,", 30); tsub_copy(&s_commands[300], "$IST,$ISP,$OFF,DBUG,FREN,$PAR,", 30); tsub_copy(&s_commands[330], "ARRB,ARRZ,$SYS,DABS,DROU,DTRU,", 30); tsub_copy(&s_commands[360], "$SWP,$SOR,$CNT,$PKD,DPK$,DTOF,", 30); tsub_copy(&s_commands[390], "FINP,FOUT,FADD,DSYS,VARI,SUBR,", 30); tsub_copy(&s_commands[420], "$COD,$TOE,DLOG,DSIN,DARC,ADDI,", 30); tsub_copy(&s_commands[450], "$DOT,$HSH,DED$,GTAG,GOTO,DPOW,", 30); tsub_copy(&s_commands[480], "DCUT,", 5); /* go through lines and put command numbers in iga_link_commands */ ig_pline_ix = 0; i_loop = 1; while(i_loop == 1) { /* get length of line ig_pline_ix */ ig_pline_lg = iga_plines_lg[ig_pline_ix]; /* put line ig_pline_ix into sg_pline */ tsub_copy(sg_pline, psga_plines[ig_pline_ix], ig_pline_lg); /* lookup command in s_commands */ iz = tfnn_string_lookup(s_commands, 500, sg_pline, 4); if(iz >= 0) { /* get the command number into i_command */ /* the first command is command 1 */ i_command = iz / 5 + 1; /* optimized 2008/01/23 */ /* some commands are really the same */ /* DWHI is the same as DIFT */ if(i_command == 12) i_command = 5; /* DCUT make into 12 */ if(i_command == 97) i_command = 12; /* DIF1 is the same as DIFT */ if(i_command == 52) i_command = 5; /* $IF1 is the same as $IFT */ if(i_command == 53) i_command = 30; /* $WHI is the same as $IFT */ if(i_command == 44) i_command = 30; /* ENDW is the same as ELSE */ /* if(i_command == 17) i_command = 13; */ /* GOTO is the same as ELSE */ if(i_command == 95) i_command = 13; /* GTAG is the same as ENDI */ if(i_command == 94) i_command = 14; /* store command number in iga_link_commands */ iga_link_commands[ig_pline_ix] = i_command; } else { /* unknown command */ tsub_show_pline_by_index(ig_pline_ix); tsub_out79("bad command at link", 19); tsub_inp79(); ig_exit = 1; i_loop++; } ig_pline_ix++; if(ig_pline_ix >= PLINES) i_loop++; if(iga_plines_lg[ig_pline_ix] == 0) i_loop++; } } /* sub_program_link_commands */ void sub_program_validate_commands(void) { /* updated 2011/05/10 */ /* 2008/12/06, 2008/01/30, 2007/08/07, 2007/04/10, 2007/01/14 */ /* 2006/10/26, 2006/06/21, 2006/06/11, 2006/06/09, 2006/05/31 */ /* 2006/05/23, 2006/05/12, 2006/04/08, 2006/03/17, 2006/01/17 */ /* 2005/11/02, 2005/11/01, 2005/10/29, 2005/09/18, 2005/09/07 */ /* 2005/09/05, 2005/09/04, 2005/08/07, 2005/08/06, 2005/08/05 */ /* edit the form of the commands */ int i_loop, i_command; /* DDEC,DDUO,DFAK,DFAC,DIFT,DINC, 6 DRAN,DSEC,DSET,DTO$,DTOI,DWHI, 12 ELSE,ENDI,ENDP,ENDS,ENDW,ESUB, 18 EVAR,ITOD,$APP,$BES,$CHD,$CLO, 24 $CUP,$CUT,$DAT,$DEL,$SHO,$IFT, 30 $INP,$INS,$ISD,$LEN,$OUT,$REP, 36 $SET,$TLO,$TOD,$TRB,$TRL,$TRR, 42 $TUP,$WHI,FWRI,FREA,FAPP,FLEN, 48 FDEL,FSIP,DBAD,DIF1,$IF1,$LOK, 54 $BAK,$CH$,DCH$,$TOI,ITO$,$ISC, 60 $IST,$ISP,$OFF,DBUG,FREN,$PAR, 66 ARRB,ARRZ,$SYS,DABS,DROU,DTRU, 72 $SWP,$SOR,$CNT,$PKD,DPK$,DTOF, 78 FINP,FOUT,FADD,DSYS,VARI,SUBR, 84 $COD,$TOE,DLOG,DSIN,DARC,ADDI, 90 $DOT,$HSH,DED$,GTAG,GOTO,DDUO, 96 DCUT, 97 */ ig_pline_ix = 0; i_loop = 1; while(i_loop == 1) { i_command = iga_link_commands[ig_pline_ix]; tsub_blank(sg_pline, 200); ig_pline_lg = iga_plines_lg[ig_pline_ix]; tsub_copy(sg_pline, psga_plines[ig_pline_ix], ig_pline_lg); if(i_command == 84) { /* SUBR=84 */ tsub_copy(sg_subr, sg_pline, ig_pline_lg); sg_subr[ig_pline_lg] = 0; } /* 1=decimal read */ /* 2=decimal read/write */ /* 11=string read */ /* 12=string read/write */ /* 01234567890123456789012345678901 */ /* DED$ S12345,D12345,N12345,N12345 */ /* one parameter */ if(i_command == 1 || i_command == 6 || i_command == 7 || i_command == 8) { /* DDEC=1,DINC=6,DRAN=7,DSEC=8 */ sub_program_validate_variable(5, 2); sub_program_validate_var_last(5); } else if(i_command == 27) { /* $DAT=27 */ sub_program_validate_variable(5, 12); sub_program_validate_var_last(5); } /* 1=decimal read */ /* 2=decimal read/write */ /* 11=string read */ /* 12=string read/write */ /* two parameters */ else if(i_command == 11 || i_command == 90) { /* DTOI=11,ADDI=90 */ sub_program_validate_variable(5, 1); sub_program_validate_variable(12, 1); sub_program_validate_var_last(12); } else if(i_command == 4 || i_command == 20 || i_command == 70 || i_command == 71 || i_command == 72 || i_command == 87 || i_command == 88 || i_command == 89) { /* DFAC=4,ITOD=20,DABS=70,DROU=71,DTRU=72 */ /* DLOG=87,DSIN=88,DARC=89 */ sub_program_validate_variable(5, 2); sub_program_validate_variable(12, 1); sub_program_validate_var_last(12); } else if(i_command == 5 /* || i_command == 12 changed to 5 */ || i_command == 51 || i_command == 52) { /* DIFT=5,DWHI=12,DBAD=51,DIF1=52 */ /* DIFT D12345==E12345 */ sub_program_validate_variable(5, 1); sub_program_validate_variable(13, 1); sub_program_validate_var_last(13); } else if(i_command == 58) { /* $TOI=58 */ /* 012345678901234567 */ /* $TOI,D12345,N12345 */ sub_program_validate_variable(5, 1); sub_program_validate_variable(12, 11); sub_program_validate_var_last(12); } else if(i_command == 23 || i_command == 33 || i_command == 34 || i_command == 39 || i_command == 48 || i_command == 49 || i_command == 92) { /* $CHD=23,$ISD=33,$LEN=34,$TOD=39,FLEN=48,FDEL=49,$HSH=92 */ sub_program_validate_variable(5, 2); sub_program_validate_variable(12, 11); sub_program_validate_var_last(12); } else if(i_command == 59) { /* ITO$=59 */ sub_program_validate_variable(5, 12); sub_program_validate_variable(12, 1); sub_program_validate_var_last(12); } else if(i_command == 22 || i_command == 24 || i_command == 25 || i_command == 38 || i_command == 40 || i_command == 41 || i_command == 42 || i_command == 43 || i_command == 79 || i_command == 85) { /* $BES=22,$CLO=24,$CUP=25,$TLO=38,$TRB=40,$TRL=41 */ /* $TRR=42,$TUP=43,FINP=79, $COD=85 */ sub_program_validate_variable(5, 12); sub_program_validate_variable(12, 11); sub_program_validate_var_last(12); } else if(i_command == 30 || i_command == 43 || i_command == 53) { /* $IFT=30,$WHI=43,$IF1=53 */ /* $IFT S12345==T12345 */ sub_program_validate_variable(5, 11); sub_program_validate_variable(13, 11); sub_program_validate_var_last(13); } /* 1=decimal read */ /* 2=decimal read/write */ /* 11=string read */ /* 12=string read/write */ /* three parameters */ else if(i_command == 96 || i_command == 2 || i_command == 3) { /* DPOW=96,DDUO=2,DFAK=3 */ sub_program_validate_variable(5, 2); sub_program_validate_variable(12, 1); sub_program_validate_variable(19, 1); sub_program_validate_var_last(19); } else if(i_command == 76) { /* $PKD=76 */ sub_program_validate_variable(5, 2); sub_program_validate_variable(12, 1); sub_program_validate_variable(19, 11); sub_program_validate_var_last(19); } else if(i_command == 47 || i_command == 60 || i_command == 61 || i_command == 62 || i_command == 65 || i_command == 75 || i_command == 80 || i_command == 81) { /* FAPP=47,$ISC=60,$IST=61,$ISP=62,FREN=65 */ /* $CNT=75,FOUT=80,FADD=81 */ sub_program_validate_variable(5, 2); sub_program_validate_variable(12, 11); sub_program_validate_variable(19, 11); sub_program_validate_var_last(19); } else if(i_command == 28 || i_command == 77 || i_command == 78) { /* $DEL=28,DPK$=77,DTOF=78 */ sub_program_validate_variable(5, 12); sub_program_validate_variable(12, 1); sub_program_validate_variable(19, 1); sub_program_validate_var_last(19); } else if(i_command == 32 || i_command == 36) { /* $INS=32,$REP=36 */ sub_program_validate_variable(5, 12); sub_program_validate_variable(12, 1); sub_program_validate_variable(19, 11); sub_program_validate_var_last(19); } else if(i_command == 50) { /* FSIP=50 */ sub_program_validate_variable(5, 12); sub_program_validate_variable(12, 11); sub_program_validate_variable(19, 2); sub_program_validate_var_last(19); } else if(i_command == 56 || i_command == 63 || i_command == 74) { /* $CH$=56,$OFF=63,$SOR=74 */ sub_program_validate_variable(5, 12); sub_program_validate_variable(12, 11); sub_program_validate_variable(19, 1); sub_program_validate_var_last(19); } else if(i_command == 73) { /* $SWP=73 */ sub_program_validate_variable(5, 12); sub_program_validate_variable(12, 11); sub_program_validate_variable(19, 11); sub_program_validate_var_last(19); } /* 1=decimal read */ /* 2=decimal read/write */ /* 11=string read */ /* 12=string read/write */ /* four parameters */ else if(i_command == 45 || i_command == 54 || i_command == 55) { /* FWRI=45,$LOK=54,$BAK */ sub_program_validate_variable(5, 2); sub_program_validate_variable(12, 11); sub_program_validate_variable(19, 1); sub_program_validate_variable(26, 11); sub_program_validate_var_last(26); } else if(i_command == 93 || i_command == 10) { /* DED$=93,DTO$=10 */ sub_program_validate_variable(5, 12); sub_program_validate_variable(12, 1); sub_program_validate_variable(19, 1); sub_program_validate_variable(26, 1); sub_program_validate_var_last(26); } else if(i_command == 26 || i_command == 46) { /* $CUT=26,FREA=46 */ sub_program_validate_variable(5, 12); sub_program_validate_variable(12, 11); sub_program_validate_variable(19, 1); sub_program_validate_variable(26, 1); sub_program_validate_var_last(26); } else if(i_command == 66 || i_command == 86) { /* $PAR=66, $TOE=86 */ sub_program_validate_variable(5, 12); sub_program_validate_variable(12, 11); sub_program_validate_variable(19, 11); sub_program_validate_variable(26, 1); sub_program_validate_var_last(26); } else if(i_command == 91) { /* $DOT=91 */ sub_program_validate_variable(5, 2); sub_program_validate_variable(12, 11); sub_program_validate_variable(19, 11); sub_program_validate_variable(26, 1); sub_program_validate_var_last(26); } else if(i_command == 12) { /* DCUT=97 changed to 12 */ sub_program_validate_variable(5, 2); sub_program_validate_variable(12, 11); sub_program_validate_variable(19, 1); sub_program_validate_variable(26, 1); sub_program_validate_var_last(26); } /* expressions */ else if(i_command == 9) { /* DSET=9 */ /* 0123456789012345678 */ /* DSET,D12345=+N12345 */ sub_program_validate_variable(5, 2); sub_program_validate_expression(13, 1); } else if(i_command == 29 || i_command == 35) { /* $SHO=29,$OUT=35 */ /* 0123456789012345678901234 */ /* $SHO,S12345+T12345+S12345 */ sub_program_validate_expression(5, 11); } else if(i_command == 21 || i_command == 31 || i_command == 37) { /* $APP=21,$INP=31,$SET=37 */ /* 0123456789012345678901234 */ /* $APP,S12345,T12345+S12345 */ sub_program_validate_variable(5, 12); sub_program_validate_expression(12, 11); } /* DDEC,DDUO,DFAK,DFAC,DIFT,DINC, 6 DRAN,DSEC,DSET,DTO$,DTOI,DWHI, 12 ELSE,ENDI,ENDP,ENDS,ENDW,ESUB, 18 EVAR,ITOD,$APP,$BES,$CHD,$CLO, 24 $CUP,$CUT,$DAT,$DEL,$SHO,$IFT, 30 $INP,$INS,$ISD,$LEN,$OUT,$REP, 36 $SET,$TLO,$TOD,$TRB,$TRL,$TRR, 42 $TUP,$WHI,FWRI,FREA,FAPP,FLEN, 48 FDEL,FSIP,DBAD,DIF1,$IF1,$LOK, 54 $BAK,$CH$,DCH$,$TOI,ITO$,$ISC, 60 $IST,$ISP,$OFF,DBUG,FREN,$PAR, 66 ARRB,ARRZ,$SYS,DABS,DROU,DTRU, 72 $SWP,$SOR,$CNT,$PKD,DPK$,DTOF, 78 FINP,FOUT,FADD,DSYS,VARI,SUBR, 84 $COD,$TOE,DLOG,DSIN,DARC,ADDI, 90 $DOT,$HSH,DED$,GTAG,GOTO,DDUO, 96 DCUT, 97 */ ig_pline_ix++; if(ig_pline_ix >= PLINES) i_loop++; if(iga_plines_lg[ig_pline_ix] == 0) i_loop++; if(ig_exit == 1) i_loop++; } } /* sub_program_validate_commands */ void sub_program_validate_variable(int ip_beg, int ip_type) { /* updated 2010/05/10, 2007/08/07, 2007/05/04 */ /* 2006/06/11, 2005/12/05, 2005/12/04, 2005/12/01, 2005/10/29 */ /* 2005/09/05, 2005/09/04, 2005/08/07, 2005/08/06, 2005/08/05 */ /* edit variable */ char c_1; int iz; int i_error = 2; /* sg_pline,ig_pline_lg */ /* 012345 */ /* N12345 */ c_1 = sg_pline[ip_beg]; /* is the index numeric */ iz = tfni_is_digits(&sg_pline[ip_beg + 1], 5); if(iz != 1) i_error = 1; /* decimal variable types */ /* D=global decimal variable */ /* E=local decimal variable */ /* F=stored decimal constant */ /* N=positive number */ /* M=negative number */ /* string variable types */ /* C=character literal */ /* S=global string variable */ /* T=local string variable */ /* U=stored string literal */ /* 1=decimal read */ /* 2=decimal read/write */ /* 11=string read */ /* 12=string read/write */ if(ip_type == 1) { /* decimal read */ if(c_1 != 'D' && c_1 != 'E' && c_1 != 'F' && c_1 != 'N' && c_1 != 'M') i_error = 1; } else if(ip_type == 2) { /* decimal read/write */ if(c_1 != 'D' && c_1 != 'E') i_error = 1; } else if(ip_type == 11) { /* string read */ if(c_1 != 'C' && c_1 != 'S' && c_1 != 'T' && c_1 != 'U' && c_1 != 'D' && c_1 != 'E' && c_1 != 'F' && c_1 != 'N' && c_1 != 'M') i_error = 1; } else if(ip_type == 12) { /* string read/write */ if(c_1 != 'S' && c_1 != 'T') i_error = 1; } if(i_error == 1) { puts(sg_subr); tsub_out79(&sg_pline[ip_beg], 6); tsub_show_pline_by_index(ig_pline_ix); sub_program_error_end("bad variable", 12); } } /* sub_program_validate_variable */ void sub_program_validate_var_last(int ip_beg) { /* updated 2006/06/21, 2005/10/29 */ /* validate to see if last variable is last */ /* sg_pline,ig_pline_lg */ /* 012345 */ /* N12345 */ if(sg_pline[ip_beg + 6] != ';') { puts("bad last"); ig_exit = 1; tsub_show_pline_by_index(ig_pline_ix); sub_program_error_end("bad last var", 12); } } /* sub_program_validate_var_last */ void sub_program_validate_expression(int ip_beg, int ip_type) { /* updated 2010/01/17 */ /* 2010/01/11, 2008/02/02, 2007/10/11, 2007/07/08, 2007/05/04 */ /* 2007/04/11, 2005/12/05, 2005/10/29, 2005/09/05, 2005/09/04 */ int i_byte; int i_error = 2; char c_1; /* sg_pline,ig_pline_lg */ if(ip_type == 1) { /* validate decimal expression */ /* 012345678901234567890123456 */ /* DSET,D12345=+N12345*D12345; */ if(sg_pline[11] != '=') i_error = 1; if(sg_pline[12] != '+' && sg_pline[12] != '-') i_error = 1; i_byte = ip_beg; for(; i_byte < ig_pline_lg; i_byte = i_byte + 7) { /* validate the operator */ c_1 = sg_pline[i_byte - 1]; if(c_1 != '+' && c_1 != '-' && c_1 != '*' && c_1 != '/' && c_1 != '\\' && c_1 != '^' && c_1 != '%' && c_1 != '@' && c_1 != '?') i_error = 1; sub_program_validate_variable(i_byte, 1); } } else if(ip_type == 11) { /* validate string expression */ /* 012345678901234567890123456 */ /* $SET,S12345=N12345*D12345; */ /* if $SET then must have = in 11 */ if(tfni_compare_strings(sg_pline, "$SET", 4) == 0 && sg_pline[11] != '=') i_error = 1; i_byte = ip_beg; for(; i_byte < ig_pline_lg;) { /* validate the operator */ c_1 = sg_pline[i_byte - 1]; if(c_1 != '+' && c_1 != ',' && c_1 != '=') i_error = 1; sub_program_validate_variable(i_byte, 11); i_byte = i_byte + 7; } if(ig_pline_lg - ip_beg < 7) i_error = 1; } if(i_error == 1) { ig_exit = 1; tsub_out79(&sg_pline[ip_beg], 6); tsub_show_pline_by_index(ig_pline_ix); sub_program_error_end("bad variable/op", 15); } } /* sub_program_validate_expression */ void sub_program_link_var(void) { /* updated 2011/01/23 */ /* link commands parm1,parm2 into iga_var_link1,iga_var_link2 */ int i_command, i_index, i_loop, iz; /* initialize */ for(iz = 0; iz < PLINES; iz++) { iga_var_link1[iz] = 0; iga_var_link2[iz] = 0; } i_index = 0; i_loop = 1; while(i_loop == 1) { /* get the commnads into iga_link_commands */ ig_pline_lg = iga_plines_lg[i_index]; tsub_copy(sg_pline, psga_plines[i_index], ig_pline_lg); i_command = 0; if(tfni_compare_strings(sg_pline, "ITOD", 4) == 0) i_command = 1; if(tfni_compare_strings(sg_pline, "DWHI", 4) == 0) i_command = 2; if(tfni_compare_strings(sg_pline, "$WHI", 4) == 0) i_command = 2; if(tfni_compare_strings(sg_pline, "DIFT", 4) == 0) i_command = 2; if(tfni_compare_strings(sg_pline, "$IFT", 4) == 0) i_command = 2; if(tfni_compare_strings(sg_pline, "DIF1", 4) == 0) i_command = 2; if(tfni_compare_strings(sg_pline, "$IF1", 4) == 0) i_command = 2; if(tfni_compare_strings(sg_pline, "DBAD", 4) == 0) i_command = 2; if(tfni_compare_strings(sg_pline, "DSET", 4) == 0) i_command = 2; if(i_command == 1) { /* commands with one byte between parm1 and parm2 */ /* 0123456789012345678 */ /* DIFT E12345=N12345 */ /* 533328 = 480000 + 48000 + 4800 + 480 + 48 */ iga_var_link1[i_index] = sg_pline[6] * 10000 + sg_pline[7] * 1000 + sg_pline[8] * 100 + sg_pline[9] * 10 + sg_pline[10] - 533328; iga_var_link2[i_index] = sg_pline[13] * 10000 + sg_pline[14] * 1000 + sg_pline[15] * 100 + sg_pline[16] * 10 + sg_pline[17] - 533328; } if(i_command == 2) { /* commands with two bytes between parm1 and parm2 */ /* 0123456789012345678 */ /* DIFT E12345==N12345 */ /* 533328 = 480000 + 48000 + 4800 + 480 + 48 */ iga_var_link1[i_index] = sg_pline[6] * 10000 + sg_pline[7] * 1000 + sg_pline[8] * 100 + sg_pline[9] * 10 + sg_pline[10] - 533328; iga_var_link2[i_index] = sg_pline[14] * 10000 + sg_pline[15] * 1000 + sg_pline[16] * 100 + sg_pline[17] * 10 + sg_pline[18] - 533328; } i_index++; if(iga_plines_lg[i_index] == 0 || i_index >= PLINES) i_loop++; } } /* void sub_program_link_var(void) */ void sub_program_link_dift_dwhi(void) { /* updated 2011/01/23 */ /* 2011/01/17, 2010/02/25, 2008/01/29, 2008/01/07, 2006/09/26 */ /* 2006/09/24, 2005/08/04, 2005/04/09, 2005/02/27, 2004/11/27 */ /* link following commands into iga_links */ /* DWHI,$WHI,ENDW,DIFT,$IFT,ELSE,ENDI,ESUB,SUBR,ENDS,DIF1,$IF1 */ int ia_stack[PSTACK], ia_lines[PSTACK], i_stack, i_command; int i_index, i_loop, i_line, i_error, iz; /* initialize */ for(iz = 0; iz < PLINES; iz++) { iga_links[iz] = 0; iga_link_commands[iz] = 0; } for(iz = 0; iz < PSTACK; iz++) { /* only 10 to pstack-10 of ia_stack and ia_lines are used */ ia_stack[iz] = 0; ia_lines[iz] = 0; } i_index = 0; i_loop = 1; while(i_loop == 1) { /* get the commnads into iga_link_commands */ ig_pline_lg = iga_plines_lg[i_index]; tsub_copy(sg_pline, psga_plines[i_index], ig_pline_lg); i_command = 0; if(tfni_compare_strings(sg_pline, "DWHI", 4) == 0) i_command = 1; if(tfni_compare_strings(sg_pline, "$WHI", 4) == 0) i_command = 1; if(tfni_compare_strings(sg_pline, "DIFT", 4) == 0) i_command = 2; if(tfni_compare_strings(sg_pline, "$IFT", 4) == 0) i_command = 2; if(tfni_compare_strings(sg_pline, "ELSE", 4) == 0) i_command = 3; if(tfni_compare_strings(sg_pline, "ENDI", 4) == 0) i_command = 4; if(tfni_compare_strings(sg_pline, "ENDW", 4) == 0) i_command = 5; if(tfni_compare_strings(sg_pline, "ESUB", 4) == 0) i_command = 6; if(tfni_compare_strings(sg_pline, "SUBR", 4) == 0) i_command = 7; if(tfni_compare_strings(sg_pline, "ENDS", 4) == 0) i_command = 8; if(tfni_compare_strings(sg_pline, "DIF1", 4) == 0) i_command = 9; if(tfni_compare_strings(sg_pline, "$IF1", 4) == 0) i_command = 9; iga_link_commands[i_index] = i_command; /* put variable numbers in iga_links for all else */ if(i_command == 0 && ig_pline_lg > 10) { /* 01234567890 */ /* DINC E12345 */ /* 533328 = 480000 + 48000 + 4800 + 480 + 48 */ iga_links[i_index] = sg_pline[6] * 10000 + sg_pline[7] * 1000 + sg_pline[8] * 100 + sg_pline[9] * 10 + sg_pline[10] - 533328; } i_index++; if(iga_plines_lg[i_index] == 0 || i_index >= PLINES) i_loop++; } i_error = 2; i_index = 0; i_stack = 10; i_loop = 1; while(i_loop == 1) { i_command = iga_link_commands[i_index]; if(i_command > 0) { /* we have a command to link */ /* dwhi=1, $whi=1, dift=1, $ift=1, esub=6 */ if(i_command < 3) { /* dwhi=1, $whi=1, dift=2, $ift=2 */ i_stack++; ia_stack[i_stack] = i_command; ia_lines[i_stack] = i_index; if(ig_debug == 1) { printf("i_stack=%d, i_index=%d, i_command=%d\n", i_stack, i_index, i_command); } } if(i_command == 3) { /* else=3, dift=2, $ift=2, endi=4 */ if(ia_stack[i_stack] != 2) i_error = 1; /* link dift=2, $ift=2 to here */ i_line = ia_lines[i_stack]; iga_links[i_line] = i_index; /* save line for endi=4 */ /* else in essence is now the dift,$ift */ ia_lines[i_stack] = i_index; } if(i_command == 4) { /* endi=4, dift=2, $ift=2, else=3 */ iz = ia_stack[i_stack]; if(iz != 2 && iz != 3) i_error = 1; /* link dift=2, $ift=2, else=3 to here */ i_line = ia_lines[i_stack]; iga_links[i_line] = i_index; /* if another endi next line link to it */ iz = iga_link_commands[i_index + 1]; if(iz == 4) { iga_links[i_line] = i_index + 1; /* if still another endi next line link to it */ iz = iga_link_commands[i_index + 2]; if(iz == 4) iga_links[i_line] = i_index + 2; } if(ig_debug == 1) { printf("i_stack=%d, i_index=%d, i_command=%d, i_line=%d\n", i_stack, i_index, i_command, i_line); } i_stack--; } if(i_command == 5) { /* endw=5, dwhi=1, $whi=1 */ if(ia_stack[i_stack] != 1) i_error = 1; /* link here to dwhi=1, $whi=1 */ i_line = ia_lines[i_stack]; iga_links[i_index] = i_line - 1; /* link dwhi=1, $whi=1 to here */ iga_links[i_line] = i_index; i_stack--; } /* if(i_command == 6) esub */ if(i_command == 7) { /* subr=7, ends=8 */ if(i_stack != 10) i_error = 1; i_stack++; ia_stack[i_stack] = 7; } if(i_command == 8) { /* ends=8, subr=7 */ if(i_stack != 11) i_error = 1; if(ia_stack[i_stack] != 7) i_error = 1; i_stack--; } if(i_command == 9) { /* DIF1,$IF1 */ iga_links[i_index] = i_index + 1; } } if(i_stack < 10 || i_stack > (PSTACK - 10)) i_error = 1; if(i_error == 1) { i_loop++; ig_exit = 1; tsub_show_pline_by_index(i_index); tsub_out79("bad link dift", 13); tsub_inp79(); } i_index++; if(iga_plines_lg[i_index] == 0 || i_index >= PLINES) i_loop++; } if(ig_debug == 1) { for(i_index = 0; i_index < PLINES; i_index++) { if(iga_links[i_index] > 0) printf("link debug: i_index=%d, i_link=%d\n", i_index, iga_links[i_index]); } } } /* sub_program_link_dift_dwhi */ void sub_program_link_esub(void) { /* updated 2007/10/13, 2007/04/11, 2007/04/10, 2006/09/24, 2005/10/21 */ /* 2005/04/09, 2005/04/01, 2005/03/09, 2005/02/08, 2004/11/27 */ /* ESUB,SUBR,ENDS */ /* 012345678 */ /* esub sub_do_something */ /* subr sub_do_something */ /* goto tag_top1 */ /* gtag tag_top1 */ long na_esubs[PLINES], na_subrs[PLINES]; int ia_evars[PLINES]; long na_gotos[PLINES], na_gtags[PLINES]; int i_good, i_command; int i_index, i_loop1, i_loop2, i_subr_ix, iz; long n_hash, n_esub, n_subr, n_goto, n_gtag, nz; /* iga_links was initialized in sub_program_link_dift_dwhi */ for(iz = 0; iz < PLINES; iz++) { na_esubs[iz] = -1; na_subrs[iz] = -1; ia_evars[iz] = -1; na_gotos[iz] = -1; na_gtags[iz] = -1; } /* first get the subroutine names */ /* index of last subr */ i_subr_ix = 0; i_index = 0; i_loop1 = 1; while(i_loop1 == 1) { /* put the program line in sg_pline,ig_pline_lg */ ig_pline_lg = iga_plines_lg[i_index]; tsub_copy(sg_pline, psga_plines[i_index], ig_pline_lg); /* hash the name into a long number */ n_hash = tfnn_hash(&sg_pline[5], ig_pline_lg - 5); /* do we have a subroutine command esub,subr,ends */ i_command = 0; if(tfni_compare_strings(sg_pline, "ESUB", 4) == 0) i_command = 1; if(tfni_compare_strings(sg_pline, "SUBR", 4) == 0) i_command = 2; if(tfni_compare_strings(sg_pline, "ENDS", 4) == 0) i_command = 3; if(tfni_compare_strings(sg_pline, "EVAR", 4) == 0) i_command = 4; if(tfni_compare_strings(sg_pline, "GOTO", 4) == 0) i_command = 5; if(tfni_compare_strings(sg_pline, "GTAG", 4) == 0) i_command = 6; if(i_command == 1) { /* esub */ na_esubs[i_index] = n_hash; } if(i_command == 2) { /* subr */ /* do we already have this subr */ for(nz = 0; nz < i_index; nz++) { if(na_subrs[nz] == n_hash) { ig_pline_ix = i_index; sub_program_error_end("duplicate subr", 14); i_loop1++; } } na_subrs[i_index] = n_hash; /* save position of subr for evar and gtag */ i_subr_ix = i_index; /* put in 1 for subr in na_gtags */ na_gtags[i_index] = 1; } if(i_command == 4) { /* evar */ /* save position of evar */ ia_evars[i_subr_ix] = i_index; } if(i_command == 5) { /* goto */ if(tfni_compare_strings(&sg_pline[5], "TAG_", 4) != 0) { sub_program_error_end("GOTO not TAG_", 13); i_loop1++; } na_gotos[i_index] = n_hash; } if(i_command == 6) { /* gtag */ if(tfni_compare_strings(&sg_pline[5], "TAG_", 4) != 0) { sub_program_error_end("GTAG not TAG_", 13); i_loop1++; } /* do we already have this gtag */ for(nz = i_subr_ix; nz < i_index; nz++) { if(na_gtags[nz] == n_hash) { ig_pline_ix = i_index; sub_program_error_end("duplicate gtag", 14); i_loop1++; } } na_gtags[i_index] = n_hash; } i_index++; if(i_index >= PLINES || iga_plines_lg[i_index] == 0) i_loop1++; } /* now link */ i_subr_ix = 0; i_index = 0; i_loop1 = 1; while(i_loop1 == 1) { n_esub = na_esubs[i_index]; if(n_esub >= 0) { /* we have an esub at line i_index */ /* find matching subrs */ for(i_good = 2, iz = 0; iz < PLINES; iz++) { n_subr = na_subrs[iz]; if(n_esub == n_subr) { i_good = 1; iga_links[i_index] = ia_evars[iz] - 1; } } if(i_good != 1) { /* error here */ i_loop1++; ig_exit = 1; tsub_show_pline_by_index(i_index); tsub_out79("bad link esub", 13); tsub_inp79(); } } /* save i_index for latest subr */ if(na_subrs[i_index] > 0) i_subr_ix = i_index; n_goto = na_gotos[i_index]; if(n_goto > 0) { /* we have a goto at line i_index */ /* find matching gtag */ i_good = 2; iz = i_subr_ix; i_loop2 = 1; while(i_loop2 == 1) { n_gtag = na_gtags[iz]; if(n_goto == n_gtag) { i_good = 1; iga_links[i_index] = iz; } /* stop at next subr */ iz++; if(na_gtags[iz] == 1 || iz > PLINES || iga_plines_lg[iz] == 0) i_loop2++; } if(i_good != 1) { /* error here */ i_loop1++; ig_exit = 1; tsub_show_pline_by_index(i_index); tsub_out79("bad link esub", 13); tsub_inp79(); } } i_index++; if(i_index >= PLINES || iga_plines_lg[i_index] == 0) i_loop1++; } if(ig_debug == 1) { for(i_index = 0; i_index < PLINES; i_index++) { if(iga_links[i_index] > 0) printf("link debug: i_index=%d, i_link=%d\n", i_index, iga_links[i_index]); } } } /* sub_program_link_esub */ void sub_program_error_end(char *sp_1, int ip_long) { /* updated 2009/07/10, 2007/10/16 */ /* 2007/10/11, 2007/01/14, 2007/01/08, 2005/04/03, 2005/02/17 */ int iz; for(iz = 20; iz >= 0; iz--) { tsub_show_pline_by_index(ig_pline_ix - iz); } tsub_out79(sp_1, ip_long); sub_command_dbug(); /* get timeline into sg_pass,ng_pass_lg */ tsub_timeline(); tsub_out79(sg_pass, ng_pass_lg); ig_exit = 1; puts("program will end"); tsub_inp79(); /* exit(1); */ } /* sub_program_error_end */ /* program subroutines above */ /* command subroutines below */ void sub_command_dabs(int ip1) { /* updated 2007/03/17, 2006/04/23, 2005/07/31, 2005/03/31 */ /* 012345678901234567 */ /* dabs D12345,D12345 */ /* 1=dabs, 2=drou, 3=dtru, 4=dlog, 5=dsin, 6=darc */ int i_negative = 2; double d_number1, d_number2; double dz; sub_fetch_decimal_variable_1dbl(&psg_pline[12]); d_number1 = dg_1pass; /* d_number2 is always positive */ if(d_number1 < 0) { i_negative = 1; d_number2 = - d_number1; } else d_number2 = d_number1; if(ip1 == 1) dg_1pass = d_number2; /* DABS */ else if(ip1 == 2) { /* DROU */ /* 0.5 is too much with numbers close to 2^53 */ dg_1pass = floor(d_number2 + 0.499); if(i_negative == 1) dg_1pass = -dg_1pass; } else if(ip1 == 3) { /* DTRU */ dg_1pass = floor(d_number2); if(i_negative == 1) dg_1pass = -dg_1pass; } else if(ip1 == 4) { /* DLOG */ if(d_number2 == 0) d_number2 = 1; dg_1pass = log10(d_number2); } else if(ip1 == 5) { /* DSIN */ /* M_PI = 3.14159... */ dz = 2 * 3.1415926535897932385; if(d_number1 > dz) d_number1 = dz; else if(d_number1 < -dz) d_number1 = -dz; dg_1pass = sin(d_number1); } else if(ip1 == 6) { /* DARC */ if(d_number1 > 1) d_number1 = 1; else if(d_number1 < -1) d_number1 = -1; dg_1pass = asin(d_number1); } sub_store_decimal_variable_in_link(); } /* sub_command_dabs */ void sub_command_dbad(void) { /* updated 2009/07/05, 2005/02/27 */ tsub_show_pline(ig_pline_ix, psg_pline, ig_pline_lg); /* get timeline into sg_pass,ng_pass_lg */ tsub_timeline(); tsub_out79(sg_pass, ng_pass_lg); tsub_out79("dbad bad", 8); tsub_inp79(); ig_exit = 1; } /* sub_command_dbad */ void sub_command_dfac(void) { /* updated 2006/11/14, 2006/10/27, 2005/05/02, 2005/03/12, 2005/02/17 */ /* 012345678901234567 */ /* dfac d00001,d00002 */ double d_number; double d_factor = 1.0; double d_root = 1.0; double d_divisor = 3.0; int i_loop = 1; /* get the number */ sub_fetch_decimal_variable_1dbl(&psg_pline[12]); d_number = floor(fabs(dg_1pass)); if(d_number < 4.0) i_loop++; else { d_root = sqrt(d_number); /* is 2 a factor */ if(fmod(d_number, 2) == 0.0) { i_loop++; d_factor = 2.0; } } while(i_loop == 1) { /* do we have a prime */ /* try d_divisor */ if(fmod(d_number, d_divisor) == 0.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor; } else { d_divisor = d_divisor + 2.0; if(d_divisor > d_root) i_loop++; } } dg_1pass = d_factor; sub_store_decimal_variable_in_link(); } /* sub_command_dfac */ void sub_command_dfak(void) { /* updated 2012/10/18, 2012/10/17, 2008/12/06, 2007/10/07 */ /* 2007/09/22, 2007/09/21, 2007/09/20, 2007/03/28, 2007/03/02 */ /* 2007/02/27, 2007/02/24, 2006/12/01, 2006/11/14, 2006/11/11 */ /* 2006/10/27, 2006/10/26, 2005/05/02, 2005/03/12, 2005/02/17 */ /* find factor of parm2 + parm3 * 1quadrillion */ /* 0123456789012345678901234 */ /* dfak d00001,d00002,d00003 */ double d_teaquadpart; double d_teaquadmult; /* 1234567890123456 */ double d_teaquadone = 1000000000000000.0; double d_modulus; double d_factor = 1.0; double d_root = 0.0; /* 1234567890 */ double d_mult1 = 5000000000.0; double d_mult2 = 200000.0; double d_cash1; double d_divisor07 = 7.0; double d_divisor11 = 11.0; double d_divisor13 = 13.0; double d_divisor17 = 17.0; double d_divisor19 = 19.0; double d_divisor23 = 23.0; double d_divisor29 = 29.0; double d_divisor31 = 31.0; int i_loop = 1; /* get the number1 */ sub_fetch_decimal_variable_1dbl(&psg_pline[12]); d_teaquadpart = floor(fabs(dg_1pass)); sub_fetch_decimal_variable_1dbl(&psg_pline[19]); d_teaquadmult = floor(fabs(dg_1pass)); /* cash d_teaquadmult * d_mult1 in d_cash1 for later use */ d_cash1 = d_teaquadmult * d_mult1; /* trivial primes */ if(d_teaquadmult == 0.0) { if(d_teaquadpart < 4 || d_teaquadpart == 5 || d_teaquadpart == 7 || d_teaquadpart == 11 || d_teaquadpart == 13 || d_teaquadpart == 17 || d_teaquadpart == 19 || d_teaquadpart == 23 || d_teaquadpart == 29 || d_teaquadpart == 31) { i_loop++; } } /* d_teaquadmult is factored by 2,5 */ /* is 2 a factor */ if(i_loop == 1 && fmod(d_teaquadpart, 2.0) == 0.0) { i_loop++; d_factor = 2.0; } /* is 3 a factor */ /* since fmod(d_teaquadone, 3) is 1 */ if(i_loop == 1 && fmod(d_teaquadpart + d_teaquadmult, 3.0) == 0) { i_loop++; d_factor = 3.0; } /* d_teaquadmult is factored by 2,5 */ /* is 5 a factor */ if(i_loop == 1 && fmod(d_teaquadpart, 5.0) == 0.0) { i_loop++; d_factor = 5.0; } if(i_loop == 1) d_root = sqrt(d_teaquadpart + d_teaquadmult * d_teaquadone); while(i_loop == 1) { /* do we have a prime */ /* d_modulus = fmod(d_teaquadpart + fmod(d_teaquadmult * d_mult1, d_divisor) * d_mult2, d_divisor); */ /* d_divisor07 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor07) * d_mult2, d_divisor07); if(d_modulus == 0.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor07; } else { d_divisor07 = d_divisor07 + 30.0; /* d_divisor11 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor11) * d_mult2, d_divisor11); if(d_modulus == 0.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor11; } else { d_divisor11 = d_divisor11 + 30.0; /* d_divisor13 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor13) * d_mult2, d_divisor13); if(d_modulus == 0.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor13; } else { d_divisor13 = d_divisor13 + 30.0; /* d_divisor17 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor17) * d_mult2, d_divisor17); if(d_modulus == 0.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor17; } else { d_divisor17 = d_divisor17 + 30.0; /* d_divisor19 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor19) * d_mult2, d_divisor19); if(d_modulus == 0.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor19; } else { d_divisor19 = d_divisor19 + 30.0; /* d_divisor23 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor23) * d_mult2, d_divisor23); if(d_modulus == 0.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor23; } else { d_divisor23 = d_divisor23 + 30.0; /* d_divisor29 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor29) * d_mult2, d_divisor29); if(d_modulus == 0.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor29; } else { d_divisor29 = d_divisor29 + 30.0; /* d_divisor31 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor31) * d_mult2, d_divisor31); if(d_modulus == 0.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor31; } else { d_divisor31 = d_divisor31 + 30.0; if(d_divisor07 > d_root) i_loop++; } } } } } } } } } dg_1pass = d_factor; sub_store_decimal_variable_in_link(); } /* sub_command_dfak */ void sub_command_dduo(void) { /* updated 2012/10/18, 2012/10/17, 2009/09/06, 2008/12/06, 2007/10/07 */ /* 2007/09/22, 2007/09/21, 2007/09/20, 2007/03/28, 2007/03/02 */ /* 2007/02/27, 2007/02/24, 2006/12/01, 2006/11/14, 2006/11/11 */ /* 2006/10/27, 2006/10/26, 2005/05/02, 2005/03/12, 2005/02/17 */ /* find factor of parm2 + parm3 * 1quadrillion */ /* and of parm2 + 2 + parm3 * 1quadrillion */ /* 0123456789012345678901234 */ /* dduo d00001,d00002,d00003 */ double d_teaquadpart; double d_teaquadmult; /* 1234567890123456 */ double d_teaquadone = 1000000000000000.0; double d_modulus; double d_factor = 1.0; double d_root = 0.0; /* 1234567890 */ double d_mult1 = 5000000000.0; double d_mult2 = 200000.0; double d_cash1; double d_divisor07 = 7.0; double d_divisor11 = 11.0; double d_divisor13 = 13.0; double d_divisor17 = 17.0; double d_divisor19 = 19.0; double d_divisor23 = 23.0; double d_divisor29 = 29.0; double d_divisor31 = 31.0; int i_loop = 1; /* get the number1 + 2 */ sub_fetch_decimal_variable_1dbl(&psg_pline[12]); d_teaquadpart = floor(fabs(dg_1pass)) + 2; sub_fetch_decimal_variable_1dbl(&psg_pline[19]); d_teaquadmult = floor(fabs(dg_1pass)); /* cash this multiplication for later use */ d_cash1 = d_teaquadmult * d_mult1; /* trivial duo second primes */ if(d_teaquadmult == 0.0) { if(d_teaquadpart < 4 || d_teaquadpart == 5 || d_teaquadpart == 7 || d_teaquadpart == 13 || d_teaquadpart == 19 || d_teaquadpart == 31) { i_loop++; } } /* d_teaquadmult is factored by 2,5 */ /* is 2 a factor of d_teaquadpart */ if(i_loop == 1 && fmod(d_teaquadpart, 2.0) == 0.0) { i_loop++; d_factor = 2.0; } /* is 3.0 a factor */ /* since fmod(d_teaquadone, 3) is 1 */ if(i_loop == 1) { d_modulus = fmod(d_teaquadpart + d_teaquadmult, 3.0); if(d_modulus == 0.0 || d_modulus == 2.0) { i_loop++; d_factor = 3.0; } } /* d_teaquadmult is factored by 2,5 */ /* is 5 a factor of d_teaquadpart */ if(i_loop == 1) { d_modulus = fmod(d_teaquadpart, 5.0); if(d_modulus == 0.0 || d_modulus == 2.0) { i_loop++; d_factor = 5.0; } } if(i_loop == 1) d_root = sqrt(d_teaquadpart + d_teaquadmult * d_teaquadone); while(i_loop == 1) { /* do we have a prime */ /* d_modulus = fmod(d_teaquadpart + fmod(d_teaquadmult * d_mult1, d_divisor) * d_mult2, d_divisor); */ /* d_divisor07 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor07) * d_mult2, d_divisor07); if(d_modulus == 0.0 || d_modulus == 2.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor07; } else { /* d_divisor11 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor11) * d_mult2, d_divisor11); if(d_modulus == 0.0 || d_modulus == 2.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor11; } else { /* d_divisor13 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor13) * d_mult2, d_divisor13); if(d_modulus == 0.0 || d_modulus == 2.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor13; } else { /* d_divisor17 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor17) * d_mult2, d_divisor17); if(d_modulus == 0.0 || d_modulus == 2.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor17; } else { /* d_divisor19 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor19) * d_mult2, d_divisor19); if(d_modulus == 0.0 || d_modulus == 2.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor19; } else { /* d_divisor23 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor23) * d_mult2, d_divisor23); if(d_modulus == 0.0 || d_modulus == 2.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor23; } else { /* d_divisor29 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor29) * d_mult2, d_divisor29); if(d_modulus == 0.0 || d_modulus == 2.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor29; } else { /* d_divisor31 */ d_modulus = fmod(d_teaquadpart + fmod(d_cash1, d_divisor31) * d_mult2, d_divisor31); if(d_modulus == 0.0 || d_modulus == 2.0) { /* we do not have a prime */ i_loop++; d_factor = d_divisor31; } else { d_divisor07 = d_divisor07 + 30.0; if(d_divisor07 > d_root) i_loop++; else { d_divisor11 = d_divisor11 + 30.0; d_divisor13 = d_divisor13 + 30.0; d_divisor17 = d_divisor17 + 30.0; d_divisor19 = d_divisor19 + 30.0; d_divisor23 = d_divisor23 + 30.0; d_divisor29 = d_divisor29 + 30.0; d_divisor31 = d_divisor31 + 30.0; } } } } } } } } } } dg_1pass = d_factor; sub_store_decimal_variable_in_link(); } /* sub_command_dduo */ void sub_command_dift_dwhi(void) { /* updated 2011/01/17, 2008/02/10 */ /* 2008/02/02, 2008/01/26, 2005/03/12, 2005/02/27, 2004/11/28 */ /* 0123456789012345678 */ /* dift D00001==D00002 */ /* ==,>>,<<,>=,<=,<> */ int i_index; /* fetch decimal into dg_1pass */ /* D means global, E means local, F means constant, N means number */ /* N means number */ i_index = iga_var_link1[ig_pline_ix]; if(psg_pline[5] == 'N') dg_1pass = i_index; else if(psg_pline[5] == 'E') { /* local */ dg_1pass = dga_decimals[i_index + ig_dvstack_ct]; } else if(psg_pline[5] == 'D') { /* global */ dg_1pass = dga_decimals[i_index]; } else if(psg_pline[5] == 'F') { /* stored decimal literal */ dg_1pass = dga_decimals[i_index]; } /* negative number */ else if(psg_pline[5] == 'M') dg_1pass = -i_index; /* sub_fetch_decimal_variable_1dbl(&psg_pline[5]); */ /* fetch decimal into dg_2pass */ i_index = iga_var_link2[ig_pline_ix]; if(psg_pline[13] == 'N') dg_2pass = i_index; else if(psg_pline[13] == 'E') { /* local */ dg_2pass = dga_decimals[i_index + ig_dvstack_ct]; } else if(psg_pline[13] == 'D') { /* global */ dg_2pass = dga_decimals[i_index]; } else if(psg_pline[13] == 'F') { /* stored decimal literal */ dg_2pass = dga_decimals[i_index]; } /* negative number */ else if(psg_pline[13] == 'M') dg_2pass = -i_index; /* sub_fetch_decimal_variable_2dbl(&psg_pline[13]); */ /* ==,<<,<=,<>,>>,>= */ if(dg_1pass < dg_2pass) { /* <<,<=,<> */ if(psg_pline[11] == '<') ig_true = 1; else ig_true = 2; } else if(dg_1pass == dg_2pass) { /* ==,<=,>= */ if(psg_pline[12] == '=') ig_true = 1; else ig_true = 2; } else { /* <>,>>,>= */ if(psg_pline[11] == '>' || psg_pline[12] == '>') ig_true = 1; else ig_true = 2; } /* ig_true=1 means true */ } /* sub_command_dift_dwhi */ void sub_command_dinc(int ip1) { /* updated 2012/12/29 */ /* 2010/03/08, 2009/03/08, 2008/02/10, 2008/01/23, 2008/01/07 */ /* 2007/04/09, 2007/03/19, 2007/03/17, 2005/02/20, 2004/11/29 */ /* 1=DINC, 2=DDEC, 3=DSEC, 4=DRAN */ /* optimized 2008/01/23 */ long n_index; if(psg_pline[5] == 'E') n_index = ig_link_ix + ig_dvstack_ct; else n_index = ig_link_ix; /* if(n_index >= 0 && n_index < VDECIMALS) { */ if(ip1 == 2) { /* DDEC */ dga_decimals[n_index] = dga_decimals[n_index] - 1; } else if(ip1 == 3) { /* DSEC */ /* dg_1pass = clock() / CLK_TCK; */ /* dg_1pass = clock() / CLOCKS_PER_SEC; */ /* dg_1pass = time(NULL); */ /* CLOCKS_PER_SEC is always 1E6 if POSIX */ /* dg_1pass = clock() / 1000000.0; */ dga_decimals[n_index] = (double)clock() / CLOCKS_PER_SEC; } else if(ip1 == 4) { /* DRAN */ /* srand((unsigned integer)(time(NULL))); */ dga_decimals[n_index] = (double)rand() / RAND_MAX; } else if(ip1 == 1) { /* DINC */ dga_decimals[n_index]++; /* dga_decimals[n_index] = dga_decimals[n_index] + 1; */ } } /* sub_command_dinc */ void sub_command_dpow(void) { /* updated 2007/07/23, 2007/07/08, 2003/03/12, 2005/02/13 */ /* 0123456789012345678901234 */ /* dpow d00001,d00002,d00003 */ double d_number, d_power; /* get the number */ sub_fetch_decimal_variable_1dbl(&psg_pline[12]); d_number = dg_1pass; /* get the power */ sub_fetch_decimal_variable_1dbl(&psg_pline[19]); d_power = dg_1pass; /* cannot have negative number and non-integer power */ if(d_number < 0 && d_power != floor(d_power)) { d_number = fabs(d_number); } if(d_number == 0 || d_power == 0) { d_number = 1; d_power = 1; } dg_1pass = pow(d_number, d_power); sub_store_decimal_variable_in_link(); } /* sub_command_dpow */ void sub_command_dset(void) { /* updated 2011/01/28, 2011/01/25, 2009/03/08, 2008/02/10 */ /* 2008/02/02, 2008/01/30, 2007/07/23, 2007/07/08, 2007/05/06 */ /* 2007/05/04, 2007/04/11, 2006/11/10, 2005/08/20, 2005/07/31 */ /* 2005/06/11, 2005/03/12, 2005/02/19, 2005/02/11, 2004/11/27 */ /* 012345678901234567890123456789012 */ /* dset D00012=+N00543*D00001/N00003; */ double d_posresult, d_posterm; int i_loop, i_byte, i_last, n_index; char *sp_var; /* pline is in psg_pline,ig_pline_lg */ i_last = ig_pline_lg - 4; /* get decimal into dg_1pass */ /* sub_fetch_decimal_variable_1dbl(&psg_pline[13]); */ /* fetch decimal into dg_1pass */ /* D means global, E means local, F means constant, N means number */ /* N means number */ n_index = iga_var_link2[ig_pline_ix]; if(psg_pline[13] == 'N') dg_1pass = n_index; else if(psg_pline[13] == 'E') { /* local */ dg_1pass = dga_decimals[n_index + ig_dvstack_ct]; } else if(psg_pline[13] == 'D') { /* global */ dg_1pass = dga_decimals[n_index]; } else if(psg_pline[13] == 'F') { /* stored decimal literal */ dg_1pass = dga_decimals[n_index]; } /* negative number */ else if(psg_pline[13] == 'M') dg_1pass = -n_index; /* dg_1pass is the result decimal */ if(psg_pline[12] == '-') dg_1pass = -dg_1pass; i_byte = 19; i_loop = 1; if(i_byte > i_last) i_loop++; while(i_loop == 1) { sp_var = &psg_pline[i_byte]; /* fetch decimal into dg_2pass */ /* sub_fetch_decimal_variable_2dbl(&psg_pline[i_byte + 1]); */ /* fetch/store use sg_pass, ng_pass_lg, dg_2pass */ /* char 48 is zero */ /* n_index = tfni_string_to_integer(&sp_var[1], 5); */ n_index = sp_var[2] * 10000 + sp_var[3] * 1000 + sp_var[4] * 100 + sp_var[5] * 10 + sp_var[6] - 533328; /* D means global, E means local, F means constant, N means number */ /* N means positive integer */ if(sp_var[1] == 'N') dg_2pass = n_index; else if(sp_var[1] == 'E') { /* local */ dg_2pass = dga_decimals[n_index + ig_dvstack_ct]; } else if(sp_var[1] == 'D') { /* global */ dg_2pass = dga_decimals[n_index]; } else if(sp_var[1] == 'F') { /* stored decimal literal */ dg_2pass = dga_decimals[n_index]; } /* negative number */ else if(sp_var[1] == 'M') dg_2pass = -n_index; /* else sub_program_error_end("bad dec var", 11); */ if(sp_var[0] == '+') dg_1pass = dg_1pass + dg_2pass; else if(sp_var[0] == '-') dg_1pass = dg_1pass - dg_2pass; else if(sp_var[0] == '*') dg_1pass = dg_1pass * dg_2pass; else if(sp_var[0] == '/') { if(dg_2pass == 0) { i_loop++; sub_program_error_end("zero div", 8); } else dg_1pass = dg_1pass / dg_2pass; } else if(sp_var[0] == '\\') { /* \ is the integer divide operator */ d_posresult = floor(fabs(dg_1pass) + 0.499); d_posterm = floor(fabs(dg_2pass) + 0.499); if(d_posterm == 0) { i_loop++; sub_program_error_end("zero int div", 12); } else { d_posresult = floor(d_posresult / d_posterm); if(dg_1pass < 0) d_posresult = - d_posresult; if(dg_2pass < 0) d_posresult = - d_posresult; dg_1pass = d_posresult; } } else if(sp_var[0] == '%') { /* % is the mod operator */ /* 0.5 is too much with numbers close to 2^53 */ d_posresult = floor(fabs(dg_1pass) + 0.499); d_posterm = floor(fabs(dg_2pass) + 0.499); if(dg_2pass == 0) { i_loop++; sub_program_error_end("zero mod", 8); } else { d_posresult = fmod(d_posresult, d_posterm); if(dg_1pass < 0) d_posresult = - d_posresult; dg_1pass = d_posresult; } } else if(sp_var[0] == '^') { /* ^ is the exponentiation operator */ /* negatives cannot be raised to a non-integer power */ if(dg_1pass < 0 && dg_2pass != floor(dg_2pass)) { dg_1pass = fabs(dg_1pass); } if(dg_1pass == 0 || dg_2pass == 0) { dg_1pass = 1; dg_2pass = 1; } dg_1pass = pow(dg_1pass, dg_2pass); } else if(sp_var[0] == '@') { /* @ is the round operator */ d_posresult = fabs(dg_1pass); dg_2pass = floor(fabs(dg_2pass) + 0.001); d_posresult = floor(d_posresult * pow(10, dg_2pass) + 0.499); d_posresult = d_posresult / pow(10, dg_2pass); if(dg_1pass < 0) dg_1pass = -d_posresult; else dg_1pass = d_posresult; } else if(sp_var[0] == '?') { /* ? is the truncate operator */ d_posresult = fabs(dg_1pass); dg_2pass = floor(fabs(dg_2pass) + 0.001); d_posresult = floor(d_posresult * pow(10, dg_2pass) + 0.001); d_posresult = d_posresult / pow(10, dg_2pass); if(dg_1pass < 0) dg_1pass = -d_posresult; else dg_1pass = d_posresult; } else { i_loop++; sub_program_error_end("bad op", 6); } i_byte = i_byte + 7; if(i_byte >= i_last) i_loop++; } /* store dg_1pass */ /* sub_store_decimal_variable_in_link(); */ if(psg_pline[5] == 'E') n_index = iga_var_link1[ig_pline_ix] + ig_dvstack_ct; else n_index = iga_var_link1[ig_pline_ix]; /* if(n_index >= 0 && n_index < VDECIMALS) */ dga_decimals[n_index] = dg_1pass; } /* sub_command_dset */ void sub_command_dsys(void) { /* updated 2010/04/15, 2005/10/07, 2005/04/12 */ /* 012345678901234567 */ /* DSYS D12345,D12345 */ double d_total; int i_which, iz; sub_fetch_decimal_variable_int(&psg_pline[12]); i_which = ig_pass_int; d_total = 0; if(i_which == 1) { /* total up string lengths */ for(iz = 0; iz < PLINES; iz++) d_total = d_total + iga_plines_lg[iz]; for(iz = 0; iz < SARRAY; iz++) d_total = d_total + iga_sarray_lg[iz]; for(iz = 0; iz < VSTRINGS; iz++) d_total = d_total + nga_strings_lg[iz]; d_total = d_total + ng_pass_lg + ng_buff1_lg + ng_buff2_lg; } else if(i_which == 2) d_total = dg_plines_done; else if(i_which == 3) d_total = ig_plines_total_count; dg_1pass = d_total; sub_store_decimal_variable_in_link(); } /* sub_command_dsys */ void sub_command_dtoi(int ip1) { /* updated 2010/04/04, 2008/02/10 */ /* 2008/02/02, 2008/01/23, 2006/04/29, 2005/03/12, 2005/02/24 */ /* 012345678901234567 */ /* DTOI D00001,D00002 */ /* 1=DTOI, 3=ADDI */ /* optimized 2008/01/23 */ long n_index; double d_number; if(ip1 == 1) { /* DTOI */ sub_fetch_decimal_variable_lng(&psg_pline[5]); n_index = ng_pass_long; /* fetch the decimal into dg_1pass */ sub_fetch_decimal_variable_1dbl(&psg_pline[12]); if(n_index >= 1 && n_index <= DARRAY) dga_darray[n_index - 1] = dg_1pass; else sub_program_error_end("dtoi bad index", 14); } else if(ip1 == 3) { /* ADDI */ sub_fetch_decimal_variable_lng(&psg_pline[5]); n_index = ng_pass_long; sub_fetch_decimal_variable_1dbl(&psg_pline[12]); d_number = dg_1pass; if(n_index >= 1 && n_index <= DARRAY) dga_darray[n_index - 1] = dga_darray[n_index - 1] + d_number; else sub_program_error_end("dtoi bad index", 14); } } /* sub_command_dtoi */ void sub_command_itod(void) { /* updated 2011/01/24, 2011/01/23, 2009/03/08, 2008/07/19, 2008/02/10 */ /* 2008/02/02, 2008/01/23, 2006/04/29, 2005/03/12, 2005/02/24 */ /* 012345678901234567 */ /* ITOD D00001,D00002 */ long n_index, nz; double dz = 0.0; /* fetch/store use sg_pass, ng_pass_lg, dg_1pass */ /* char 48 is zero */ /* n_index = tfni_string_to_integer(&sp_var[1], 5); */ /* n_index = psg_pline[13] * 10000 + psg_pline[14] * 1000 + psg_pline[15] * 100 + psg_pline[16] * 10 + psg_pline[17] - 533328; */ /* fetch decimal into dg_2pass */ n_index = iga_var_link2[ig_pline_ix]; /* D means global, E means local, F means constant, N means number */ if(psg_pline[12] == 'E') { /* local */ dz = dga_decimals[n_index + ig_dvstack_ct]; } else if(psg_pline[12] == 'D') { /* global */ dz = dga_decimals[n_index]; } else if(psg_pline[12] == 'F') { /* stored decimal literal */ dz = dga_decimals[n_index]; } /* number */ else if(psg_pline[12] == 'N') dz = n_index; else if(psg_pline[12] == 'M') dz = -n_index; /* this will not work if dz=DARRAY + 0.1 */ /* which would be bad programming anyway */ /* 0.5 is too much for numbers close to 2^53 */ n_index = (int)floor(dz + 0.499) - 1; if(n_index >= 0 && n_index < DARRAY) { /* dg_1pass = dga_darray[n_index]; sub_store_decimal_variable_in_link(); */ nz = iga_var_link1[ig_pline_ix]; if(psg_pline[5] == 'E') /* local */ dga_decimals[nz + ig_dvstack_ct] = dga_darray[n_index]; else /* global */ dga_decimals[nz] = dga_darray[n_index]; } else sub_program_error_end("dtoi bad index", 14); } /* sub_command_itod */ void sub_command_dtos(int ip1) { /* updated 2006/05/19, 2006/05/08, 2005/11/05, 2005/04/25, 2005/04/24 */ /* 2005/04/13, 2005/04/05, 2005/03/31, 2005/02/12, 2004/12/02 */ /* 01234567890123456789012345678901 */ /* dto$ S00001,D00001,D00002,D00003 */ /* ded$ S00001,D00001,D00002,D00003 */ int i_parm3, i_parm4, i_long, i_digit; int i_neg, i_beg, i_dot, i_just, ix, iy, iz; double d_number, d_more; char sy[100], sz[100]; sub_fetch_decimal_variable_1dbl(&psg_pline[12]); d_number = dg_1pass; /* make number positive and i_neg = 1 means negative */ if(d_number < 0) { i_neg = 1; d_number = -d_number; } else i_neg = 2; sub_fetch_decimal_variable_int(&psg_pline[19]); i_parm3 = ig_pass_int; if(i_parm3 > 30) i_parm3 = 30; if(i_parm3 < 1) i_parm3 = 0; sub_fetch_decimal_variable_int(&psg_pline[26]); i_parm4 = ig_pass_int; if(i_parm4 > 16) i_parm4 = 16; if(i_parm4 < 1) i_parm4 = 0; if(d_number > pow(10, 16)) { /* if number greater than 10E16 */ i_beg = 1; i_long = sprintf(&sz[1], "%.15E", d_number); if(i_neg == 1) { sz[0] = '-'; i_beg = 0; i_long++; } /* copy into sg_pass,ng_pass_lg */ tsub_copy(sg_pass, &sz[i_beg], i_long); ng_pass_lg = i_long; } else { /* d_more avoids truncation problems below */ /* ie. 0.03 = 0.02999999 etc. */ d_more = 0; if(i_parm4 > 0) d_more = pow(10, -i_parm4) * 0.5001; /* do we want just the number */ i_just = 2; if(i_parm3 == 0 && i_parm4 == 0) i_just = 1; if(i_parm3 == 0 && i_parm4 > 0) i_parm3 = i_parm4 + 1; /* sz is 100 long */ tsub_blank(sz, 90); sprintf(sz, "%60.20f", d_number + d_more); tsub_blank_escapes(sz, 90); /* find . for sure */ i_dot = 39; for(iz = 20; iz < 60; iz++) { if(sz[iz] == '.') { i_dot = iz; iz = 90; } } /* no more than 16 numbers not counting leading zero left of . */ if(d_number < 1) iz = i_dot; else iz = 20; for(iy = 0; iz < 60; iz++) { if(sz[iz] >= '0' && sz[iz] <= '9') { iy++; if(iy > 16 && iz > i_dot) sz[iz] = '0'; } } /* decimal is in sz[39], i_dot=39 */ if(ip1 == 2) { /* put commas in the number if needed */ /* 1,234,567,890,123,456. */ /* sy,sz are 100 long */ tsub_copy(sy, sz, 90); /* the decimal is in sz[39] */ i_digit = 0; for(iy = 39, iz = 39; iy >= 0 ;iz--, iy--) { if(sz[iz] >= '0' && sz[iz] <= '9') { i_digit++; ix = i_digit % 3; if(i_digit > 1 && ix == 1) { sy[iy] = ','; iy--; } sy[iy] = sz[iz]; } } tsub_copy(sz, sy, 90); } /* the decimal is in sz[39] */ /* find iz = first blank going to left of decimal */ for(iz = 39; iz >= 0 && sz[iz] != ' '; iz--); /* put in leading - if needed */ if(i_neg == 1) sz[iz] = '-'; /* else add 1 to get first digit of number */ else iz++; /* iz has actual beginning of number now */ /* get i_beg = proposed beginning of field */ /* 12345678901 */ /* 123.45 */ i_beg = 39 + i_parm4 - i_parm3 + 1; /* get i_beg = actual beginning of field */ if(iz < i_beg) i_beg = iz; if(i_just == 1) { /* just the number */ i_beg = iz; /* we know that sz[39] is a "." */ /* remove trailing zeros */ /* find last non-zero byte */ for(iz = 1, iy = 65; iz == 1; iy--) { if(sz[iy] <= ' ' || sz[iy] == '0') sz[iy] = ' '; else iz = iy; } /* remove trailing decimal */ if(sz[iz] == '.') iz--; i_long = iz - i_beg + 1; } else { /* get i_long = length of field */ /* 12345678901 */ /* 123.45 */ i_long = 39 + i_parm4 - i_beg + 1; } /* if no decimal wanted */ if(i_parm3 > 0 && i_parm4 == 0) { if(i_long > i_parm3) i_long--; else i_beg--; } /* copy into sg_pass,ng_pass_lg */ tsub_copy(sg_pass, &sz[i_beg], i_long); ng_pass_lg = i_long; } sub_store_string_in_link(sg_pass, ng_pass_lg); } /* sub_command_dtos */ void sub_command_evar(void) { /* updated 2005/03/13, 2005/03/12, 2005/02/03, 2005/01/31 */ /* 012345678901234567 */ /* evar,N12345,N12345; */ int i_dvstack, i_svstack; i_dvstack = tfni_string_to_integer(&psg_pline[6], 5); i_svstack = tfni_string_to_integer(&psg_pline[13], 5); /* decimals */ /* ig_dvstack_ct is how many decimals there are before this */ ig_dvstack_ct = iga_dvstack[ig_dvstack_ix]; ig_dvstack_ix++; i_dvstack = i_dvstack + ig_dvstack_ct; iga_dvstack[ig_dvstack_ix] = i_dvstack; /* strings */ /* ig_svstack_ct is how many strings there are before this */ ig_svstack_ct = iga_svstack[ig_svstack_ix]; ig_svstack_ix++; i_svstack = i_svstack + ig_svstack_ct; iga_svstack[ig_svstack_ix] = i_svstack; } /* sub_command_evar */ void sub_command_ends(void) { /* updated 2005/02/08, 2005/02/03 */ int i_beg, i_end, iz; /* int ig_dvstack_ct, ig_svstack_ct; int ig_dvstack_ix; int iga_dvstack[VSTACK], iga_svstack[VSTACK]; */ /* decimals */ /* prepare to zero the decimal variables for this subr */ i_beg = ig_dvstack_ct + 1; i_end = iga_dvstack[ig_dvstack_ix]; for(iz = i_beg; iz <= i_end; iz++) dga_decimals[iz] = 0; /* ig_dvstack_ct is how many decimals before this subr */ ig_dvstack_ix--; iz = ig_dvstack_ix; iz--; ig_dvstack_ct = iga_dvstack[iz]; /* strings */ /* prepare to free the string variables for this subr */ i_beg = ig_svstack_ct + 1; i_end = iga_svstack[ig_svstack_ix]; for(iz = i_beg; iz <= i_end; iz++) { free(psga_strings[iz]); psga_strings[iz] = NULL; nga_strings_lg[iz] = 0; } /* ig_svstack_ct is how many decimals before this subr */ ig_svstack_ix--; iz = ig_svstack_ix; iz--; ig_svstack_ct = iga_svstack[iz]; /* get return pline number and adjust subr stack */ ig_pline_ix = iga_subr_links[ig_subr_ix]; ig_subr_ix--; } /* sub_command_ends */ void sub_command_file(int ip1) { /* updated 2007/08/23, 2006/05/23, 2005/09/11, 2005/09/10, 2005/09/03 */ /* 2005/07/26, 2005/07/25, 2005/07/24, 2005/07/02, 2005/06/20 */ /* 2005/05/09, 2005/04/27, 2005/04/12, 2005/04/05, 2005/03/31 */ /* 2005/03/13, 2005/03/12, 2005/03/07, 2005/03/03, 2005/03/02 */ /* 2005/02/13, 2005/02/12, 2005/02/11, 2005/02/09, 2004/12/04 */ /* ip1=1 fwri write a record */ /* ip1=2 frea read a record */ /* ip1=3 fadd add a record to the end */ /* ip1=4 flen get length of a file */ /* ip1=5 fdel delete a file */ /* ip1=6 fsip sip a variable length record */ /* ip1=7 fren rename a file */ /* ip1=8 finp input a whole file */ /* ip1=9 fout output a whole file */ /* ip1=10 fapp append a record to the end of a file */ /* define a file pointer needed for processing a file */ FILE *pf_file; char s_filename[100]; long n_bytes_read, n_towrite, n_byte, n_length, n_long; int i_process, i_long, i_loop; int iy, iz; if(ip1 == 1) { /* 01234567890123456789012345678901 */ /* fwri D00001,S00001,D00002,S00002 */ /* write record to a file by begin byte and length */ i_process = 1; /* get the record to write into sg_pass for length ng_pass_lg */ /* sg_pass is a char array of 8K and ng_pass_lg is a long */ sub_fetch_string_pass(26); /* copy sg_pass to sg_buff1 and put length in ng_buff1_lg */ /* sg_buff1 is a char array of 8K and ng_buff1_lg is a long */ tsub_copy(sg_buff1, sg_pass, ng_pass_lg); ng_buff1_lg = ng_pass_lg; /* get the byte into long n_byte */ /* n_byte is the beginning byte of the file to write to */ sub_fetch_decimal_variable_lng(&psg_pline[19]); /* put writeto byte in n_byte and subtract 1 to make first at 0 */ n_byte = ng_pass_long - 1; /* get the filename into sg_pass of length ng_pass_lg */ sub_fetch_string_pass(12); /* C90 expects a null character at the end of strings */ sg_pass[ng_pass_lg] = 0; /* try opening an existing file with filename in sg_pass */ /* "rb+" means read/write binary */ pf_file = fopen(sg_pass, "rb+"); /* if file pointer is NULL then file not opened */ if(pf_file == NULL) { /* if the file pointer has NULL in it the file was not opened */ /* try opening a new file */ /* "wb+" means open new file read/write binary */ pf_file = fopen(sg_pass, "wb+"); /* if the file pointer has NULL in it no file was opened */ if(pf_file == NULL) i_process++; } i_long = 0; if(i_process == 1) { /* get the length of the file plus 1 in n_length */ /* pf_file is the file pointer to the now open file */ /* next command sets file pointer to the end of the file */ /* the 0L is a type long that is zero that is an offset */ /* from the SEEK_END but here we want the end */ fseek(pf_file, 0L, SEEK_END); /* ftell gives the file pointer location then add 1 */ n_length = ftell(pf_file) + 1; /* set n_byte to no more than n_length */ /* we cannot write a record to further than the end + 1 */ if(n_byte > n_length) n_byte = n_length; /* set the file pointer to byte n_byte */ fseek(pf_file, n_byte, SEEK_SET); /* write the record in sg_buff1 for length ng_buff1_lg */ /* i_long returns the number of bytes written */ /* the 1 means length is in bytes */ i_long = fwrite(sg_buff1, 1, ng_buff1_lg, pf_file); /* close the file */ fclose(pf_file); } /* store the length written */ dg_1pass = i_long; sub_store_decimal_variable_in_link(); } else if(ip1 == 2) { /* 01234567890123456789012345678901 */ /* frea S00002,S00001,D00001,D00002 */ /* read a record by beginning byte and length */ i_process = 1; /* get the readfrom byte in n_byte */ sub_fetch_decimal_variable_lng(&psg_pline[19]); /* teapro files begin with byte 1 */ /* subtract 1 since C90 files begin in byte 0 */ n_byte = ng_pass_long - 1; if(n_byte < 0) i_process++; /* get the length to be read */ sub_fetch_decimal_variable_int(&psg_pline[26]); ng_buff1_lg = ig_pass_int; /* get the filename in sg_pass for length ng_pass_lg */ sub_fetch_string_pass(12); /* C90 expects a null character at the end of strings */ sg_pass[ng_pass_lg] = 0; if(i_process == 1) { /* try opening an existing file for read binary */ /* binary access means you get exactly what is there */ pf_file = fopen(sg_pass, "rb"); /* if file not opened then end processing */ if(pf_file == NULL) i_process++; } i_long = 0; if(i_process == 1) { /* set the file pointer to n_byte */ fseek(pf_file, n_byte, SEEK_SET); /* read the record into char array sg_buff1 for */ /* length ng_buff1_lg and put number of bytes read */ /* into integer i_long */ /* the 1 means the length is in bytes */ i_long = fread(sg_buff1, 1, ng_buff1_lg, pf_file); /* close the file */ fclose(pf_file); } /* copy the record read into sg_pass of length ng_pass_lg */ tsub_copy(sg_pass, sg_buff1, i_long); ng_pass_lg = i_long; /* store the record */ sub_store_string_in_link(sg_pass, ng_pass_lg); } else if(ip1 == 3) { /* 0123456789012345678901234 */ /* fadd D00001,S00001,S00002 */ /* add a record to the end of the file and append a line feed */ /* same as fapp but with lf instead of crlf */ i_process = 1; /* get the filename */ sub_fetch_string_pass(12); tsub_copy(s_filename, sg_pass, ng_pass_lg); s_filename[ng_pass_lg] = 0; /* get the record */ sub_fetch_string_pass(19); tsub_pass_trim_right(); tsub_copy(sg_buff1, sg_pass, ng_pass_lg); ng_buff1_lg = ng_pass_lg; /* put just a line feed at the record end */ sg_buff1[ng_buff1_lg] = 10; ng_buff1_lg++; sg_buff1[ng_buff1_lg] = 0; /* try opening an existing file */ pf_file = fopen(s_filename, "rb+"); if(pf_file == NULL) { /* try opening a new file */ pf_file = fopen(s_filename, "wb+"); if(pf_file == NULL) i_process++; } i_long = 0; if(i_process == 1) { /* get the length of the file in n_byte */ fseek(pf_file, 0L, SEEK_END); n_byte = ftell(pf_file); /* set the file pointer to n_byte */ fseek(pf_file, n_byte, SEEK_SET); /* write the record */ i_long = fwrite(sg_buff1, 1, ng_buff1_lg, pf_file); fclose(pf_file); } dg_1pass = i_long; sub_store_decimal_variable_in_link(); } else if(ip1 == 4) { /* 012345678901234567 */ /* flen D00001,S00001 */ /* get the length of the file */ i_process = 1; /* get the filename */ sub_fetch_string_pass(12); sg_pass[ng_pass_lg] = 0; /* try opening an existing file read binary */ pf_file = fopen(sg_pass, "rb"); if(pf_file == NULL) i_process++; n_length = -1; if(i_process == 1) { /* get the length of the file in n_length */ fseek(pf_file, 0L, SEEK_END); n_length = ftell(pf_file); fclose(pf_file); } dg_1pass = n_length; sub_store_decimal_variable_in_link(); } else if(ip1 == 5) { /* 012345678901234567 */ /* fdel d00001,s00001 */ /* get the filename of the file to be deleted */ sub_fetch_string_pass(12); sg_pass[ng_pass_lg] = 0; /* delete or remove the file */ iz = remove(sg_pass); if(iz == 0) dg_1pass = 1; else dg_1pass = 2; sub_store_decimal_variable_in_link(); } else if(ip1 == 6) { /* 0123456789012345678901234 */ /* fsip S00002,S00001,D00001 */ /* sip a record from a byte for a length to a line feed */ i_process = 1; /* get the byte n_byte to read */ sub_fetch_decimal_variable_lng(&psg_pline[19]); n_byte = ng_pass_long - 1; /* get the filename */ sub_fetch_string_pass(12); sg_pass[ng_pass_lg] = 0; /* try opening an existing file to read */ pf_file = fopen(sg_pass, "rb"); if(pf_file == NULL) { i_process++; n_byte = -1; } n_bytes_read = 0; if(i_process == 1) { tsub_blank(sg_buff1, VSLONG); /* set the file pointer to n_byte */ fseek(pf_file, n_byte, SEEK_SET); /* read the record */ n_bytes_read = fread(sg_buff1, 1, VSLONG, pf_file); fclose(pf_file); /* can we find a line feed=LF=10 */ n_long = n_bytes_read; iy = -5; for(iz = 0; iy == -5 && iz < n_long; iz++) { if(sg_buff1[iz] == 10) iy = iz; } if(iy > -5) { /* we found a LF at iy */ n_byte = n_byte + iy + 1; n_long = iy; if(iy > 0) { /* blank carriage return at end if any */ if(sg_buff1[iy - 1] == 13) { sg_buff1[iy - 1] = ' '; n_long--; } } } else { /* no LF found */ n_byte = n_byte + n_long; } tsub_copy(sg_pass, sg_buff1, n_long); ng_pass_lg = n_long; sub_store_string_in_link(sg_pass, ng_pass_lg); } if(n_bytes_read > 0) dg_1pass = n_byte + 1; else dg_1pass = 0; sub_store_decimal_variable(&psg_pline[19]); } else if(ip1 == 7) { /* fren */ /* 0123456789012345678901234 */ /* fren D00001,S00002,S00003 */ /* rename a file */ /* get the old filename */ sub_fetch_string_pass(19); sg_pass[ng_pass_lg] = 0; tsub_copy(s_filename, sg_pass, ng_pass_lg + 1); /* get the new filename */ sub_fetch_string_pass(12); sg_pass[ng_pass_lg] = 0; /* rename the file named in sg_pass to the name in s_filename */ iz = rename(s_filename, sg_pass); if(iz == 0) dg_1pass = 1; else dg_1pass = 2; sub_store_decimal_variable_in_link(); } else if(ip1 == 8) { /* finp */ /* 012345678901234567 */ /* finp S00002,S00001 */ /* read into a char array and entire file */ i_process = 1; /* get the filename into sg_pass,ng_pass_lg */ sub_fetch_string_pass(12); sg_pass[ng_pass_lg] = 0; if(i_process == 1) { /* try opening an existing file */ pf_file = fopen(sg_pass, "rb"); if(pf_file == NULL) i_process++; sub_store_string_in_link(" ", 0); } if(i_process == 1) { /* get the length of the file in n_length */ fseek(pf_file, 0L, SEEK_END); n_length = ftell(pf_file); /* make a string to hold the file psg_use1,ng_use1 */ ng_use1 = n_length; tsub_make_long_string(&psg_use1, ng_use1); if(ig_exit == 1) { fclose(pf_file); i_process++; sub_program_error_end("finp too long", 13); } } if(i_process == 1) { n_byte = 0; i_loop = 1; while(i_loop == 1) { /* set the file pointer to n_byte */ fseek(pf_file, n_byte, SEEK_SET); /* read the record into sg_pass,ng_pass_lg */ n_long = fread(sg_pass, 1, 4096, pf_file); tsub_copy(&psg_use1[n_byte], sg_pass, n_long); n_byte = n_byte + n_long; if(n_byte >= n_length) i_loop++; if(n_long == 0) { ng_use1 = n_byte - 1; i_loop++; } } fclose(pf_file); sub_store_string_in_link(psg_use1, ng_use1); free(psg_use1); psg_use1 = NULL; ng_use1 = 0; } } else if(ip1 == 9) { /* fout */ /* 0123456789012345678901234 */ /* fout d12345,s12345,s12345 */ /* store a char array into an entire file */ i_process = 1; /* get the filename into sg_pass,ng_pass_lg */ sub_fetch_string_pass(12); sg_pass[ng_pass_lg] = 0; sub_fetch_string3(19, &psg_use1, &ng_use1); if(ig_exit == 1) { i_process++; sub_program_error_end("fout too long", 13); } if(i_process == 1) { /* try opening a new file */ pf_file = fopen(sg_pass, "wb+"); if(pf_file == NULL) i_process++; } if(i_process == 1) { n_byte = 0; i_loop = 1; while(i_loop == 1) { /* set the file pointer to n_byte */ fseek(pf_file, n_byte, SEEK_SET); n_towrite = 4096; if((ng_use1 - n_byte) < n_towrite) n_towrite = ng_use1 - n_byte; /* put 4096 of the string from n_byte into sg_pass */ tsub_copy(sg_pass, &psg_use1[n_byte], n_towrite); /* write the record into sg_pass,ng_pass_lg */ n_long = fwrite(sg_pass, 1, n_towrite, pf_file); n_byte = n_byte + n_long; if(n_byte >= ng_use1) i_loop++; if(n_long == 0) { ng_use1 = n_byte - 1; i_loop++; } } fclose(pf_file); dg_1pass = ng_use1; sub_store_decimal_variable_in_link(); } } else if(ip1 == 10) { /* 0123456789012345678901234 */ /* fapp D00001,S00001,S00002 */ /* append a record to a file with a carriage return + line feed */ /* same as fadd but with crlf instead of just lf */ i_process = 1; /* get the filename */ sub_fetch_string_pass(12); tsub_copy(s_filename, sg_pass, ng_pass_lg); s_filename[ng_pass_lg] = 0; /* get the record */ sub_fetch_string_pass(19); tsub_pass_trim_right(); tsub_copy(sg_buff1, sg_pass, ng_pass_lg); ng_buff1_lg = ng_pass_lg; /* put a carriage return and a line feed at the record end */ sg_buff1[ng_buff1_lg] = 13; ng_buff1_lg++; sg_buff1[ng_buff1_lg] = 10; ng_buff1_lg++; sg_buff1[ng_buff1_lg] = 0; /* try opening an existing file */ pf_file = fopen(s_filename, "rb+"); if(pf_file == NULL) { /* try opening a new file */ pf_file = fopen(s_filename, "wb+"); if(pf_file == NULL) i_process++; } i_long = 0; if(i_process == 1) { /* get the length of the file in n_byte */ fseek(pf_file, 0L, SEEK_END); n_byte = ftell(pf_file); /* set the file pointer to n_byte */ fseek(pf_file, n_byte, SEEK_SET); /* write the record */ i_long = fwrite(sg_buff1, 1, ng_buff1_lg, pf_file); fclose(pf_file); } dg_1pass = i_long; sub_store_decimal_variable_in_link(); } else sub_program_error_end("file command", 12); } /* sub_command_file */ void sub_command_sapp(void) { /* updated 2011/09/26 */ /* 2005/07/21, 2005/07/20, 2005/04/05, 2005/03/12, 2005/02/21 */ /* uses long strings */ /* 0123456789012345678901234 */ /* $APP s12345,s12345+s12345 */ long n_long; int i_error = 2; /* fetch into psg_use4,ng_use4 */ sub_fetch_string3(5, &psg_use4, &ng_use4); /* from psg_pline fetch into psg_use1,ng_use1 */ sub_fetch_string_expression_use(12); n_long = ng_use4 + ng_use1; if(n_long <= MAXSTRING) { ng_use2 = n_long; tsub_make_long_string(&psg_use2, ng_use2); tsub_copy(psg_use2, psg_use4, ng_use4); tsub_copy(&psg_use2[ng_use4], psg_use1, ng_use1); ng_use2 = n_long; } else i_error = 1; if(i_error != 1) sub_store_string_in_link(psg_use2, ng_use2); else sub_program_error_end("$app too long", 13); } /* sub_command_sapp */ void sub_command_schs(int ip1) { /* updated 2005/07/03, 2005/05/06, 2005/05/11 */ /* 2005/05/09, 2005/04/05, 2005/03/27, 2005/03/12, 2005/03/06 */ /* uses long strings */ /* 0123456789012345678901234 */ /* $CH$ S00001,S00002,D00003 */ /* DCH$ S00001,D00002,D00003 */ /* OFF$ S12345,S12345,D12345 */ /* 1=$CH$, 2=DCH$, 3=$OFF */ char c_1; long nz, n_count; sub_fetch_decimal_variable_lng(&psg_pline[19]); n_count = ng_pass_long; if(n_count > MAXSTRING) n_count = MAXSTRING; if(n_count < 0) n_count = 0; if(ip1 == 1) { /* $CH$ */ sub_fetch_string3(12, &psg_use2, &ng_use2); if(ng_use2 > 0) c_1 = psg_use2[0]; else c_1 = 0; free(psg_use2); psg_use2 = NULL; tsub_make_long_string(&psg_use1, n_count); ng_use1 = n_count; for(nz = 0; nz < ng_use1; nz++) psg_use1[nz] = c_1; sub_store_string_in_link(psg_use1, ng_use1); free(psg_use1); psg_use1 = NULL; } else if(ip1 == 2) { /* DCH$ */ sub_fetch_decimal_variable_int(&psg_pline[12]); c_1 = (char)ig_pass_int; tsub_make_long_string(&psg_use1, n_count); ng_use1 = n_count; for(nz = 0; nz < n_count; nz++) psg_use1[nz] = c_1; sub_store_string_in_link(psg_use1, ng_use1); free(psg_use1); psg_use1 = NULL; } else if(ip1 == 3) { /* $OFF */ sub_fetch_string3(12, &psg_use2, &ng_use2); if(n_count > ng_use2) n_count = ng_use2; nz = ng_use2 - n_count; tsub_make_long_string(&psg_use1, n_count); ng_use1 = n_count; tsub_copy(psg_use1, &psg_use2[nz], n_count); free(psg_use2); psg_use2 = NULL; sub_store_string_in_link(psg_use1, ng_use1); free(psg_use1); psg_use1 = NULL; } } /* sub_command_schs */ void sub_command_scnt(void) { /* updated 2006/10/23, 2005/07/03, 2005/06/26, 2005/04/05, 2005/04/02 */ /* uses long strings */ /* 0123456789012345678901234 */ /* $CNT D12345,S12345,S12345 */ int iy; long n_end, n_count, nz; /* get string to find to psg_use2,ng_use2 */ sub_fetch_string3(19, &psg_use2, &ng_use2); /* get string to find in to psg_byref,ng_byref */ sub_fetch_string_byref(12); n_end = ng_byref - ng_use2; n_count = 0; for(nz = 0; nz <= n_end; nz++) { if(psg_byref[nz] == psg_use2[0]) { iy = tfni_compare_strings(&psg_byref[nz], psg_use2, ng_use2); if(iy == 0) n_count++; } } psg_byref = NULL; free(psg_use2); psg_use2 = NULL; ng_use2 = 0; dg_1pass = n_count; sub_store_decimal_variable_in_link(); } /* sub_command_scnt */ void sub_command_scut(void) { /* updated 2006/10/11 */ /* 2005/07/24, 2005/07/03, 2005/04/05, 2005/03/12, 2004/11/27 */ /* uses long strings */ /* 01234567890123456789012345678901 */ /* $cut S00001,S00002,D00001,D00002 */ long n_begin, n_long, nz; /* get the beginning byte */ sub_fetch_decimal_variable_lng(&psg_pline[19]); n_begin = ng_pass_long; /* get the length to cut */ sub_fetch_decimal_variable_lng(&psg_pline[26]); n_long = ng_pass_long; /* fetch cut from into psg_byref,ng_byref */ sub_fetch_string_byref(12); if(n_long < 0) n_long = 0; if(n_begin < 1) n_begin = 1; if(n_begin <= ng_byref) { /* get actual length of part to cut */ /* 1234567890 */ nz = ng_byref - n_begin + 1; if(n_long > nz) n_long = nz; } else { n_long = 0; n_begin = 0; } ng_use1 = n_long; tsub_make_long_string(&psg_use1, ng_use1); tsub_copy(psg_use1, &psg_byref[n_begin - 1], ng_use1); psg_byref = NULL; sub_store_string_in_link(psg_use1, ng_use1); free(psg_use1); psg_use1 = NULL; ng_use1 = 0; } /* sub_command_scut */ void sub_command_dcut(void) { /* updated 2013/04/29, 2011/05/10, 2006/10/11 */ /* 2005/07/24, 2005/07/03, 2005/04/05, 2005/03/12, 2004/11/27 */ /* uses long strings */ /* 01234567890123456789012345678901 */ /* dcut D00001,S00002,D00001,D00002 */ /* DCUT was from $CUT on 2011/05/10 */ long n_begin, n_long, ny, nz; double d_result; /* get the beginning byte */ sub_fetch_decimal_variable_lng(&psg_pline[19]); /* make n_begin the beginning byte we want */ n_begin = ng_pass_long - 1; /* get the length to cut */ sub_fetch_decimal_variable_lng(&psg_pline[26]); n_long = ng_pass_long; /* fetch string into psg_byref,ng_byref */ sub_fetch_string_byref(12); /* make ng_byref the very ending byte of the string */ ng_byref--; if(n_long < 0) n_long = 0; if(n_long > 16) n_long = 16; if(n_begin < 0) n_begin = 0; /* make n_long to be the ending byte wanted */ n_long = n_begin + n_long - 1; /* ending byte wanted cannot be greater than the string */ if(n_long > ng_byref) n_long = ng_byref; d_result = 0; for(nz = n_begin; nz <= n_long; nz++) { ny = psg_byref[nz]; /* zero is character 48, nine is 57 */ if(ny >=48 && ny <= 57) d_result = d_result * 10 + ny - 48; else nz = n_long + 4; } dg_1pass = d_result; sub_store_decimal_variable_in_link(); free(psg_use1); psg_use1 = NULL; ng_use1 = 0; } /* sub_command_dcut */ void sub_command_sdel(void) { /* updated 2005/07/16, 2005/05/12, 2005/03/12, 2004/12/09 */ /* uses long strings */ /* 0123456789012345678901234 */ /* $DEL S00001,D00001,D00002 */ long n_begin, n_long; sub_fetch_decimal_variable_lng(&psg_pline[12]); n_begin = ng_pass_long; sub_fetch_decimal_variable_lng(&psg_pline[19]); n_long = ng_pass_long; /* fetch into psg_use2,ng_use2 */ sub_fetch_string3(5, &psg_use2, &ng_use2); /* put string with delete done in sg_pass,ng_pass_lg */ tsub_use_delete21(n_begin - 1, n_long); sub_store_string_in_link(psg_use1, ng_use1); free(psg_use1); psg_use1 = NULL; free(psg_use2); psg_use2 = NULL; } /* sub_command_sdel */ void sub_command_sdat(void) { /* updated 2007/12/21, 2005/07/02, 2005/03/15, 2005/02/23, 2004/11/28 */ /* does not need long strings */ /* 01234567890 */ /* $DAT S00001 */ /* 01234567890123456789012345678901234 */ /* Sun Nov 28 19:10:06 2004 */ /* 20-NOV-2004 19:10:06 20041120191006 */ /* get timeline into sg_pass,ng_pass_lg */ tsub_timeline(); sub_store_string_in_link(sg_pass, ng_pass_lg); } /* sub_command_sdat */ void sub_command_sift_swhi(void) { /* updated 2008/01/26, 2005/07/23 */ /* 2005/07/13, 2005/04/05, 2005/03/12, 2005/02/27, 2004/11/27 */ /* uses long strings */ /* 0123456789012345678 */ /* $ift S00001==S00002 */ /* ==,>>,<<,>=,<=,<> */ int i_type, i_result; long n_long; /* get first string into psg_use1,ng_use1 */ sub_fetch_string3(5, &psg_use1, &ng_use1); /* get second string into psg_use2,ng_use2 */ sub_fetch_string3(13, &psg_use2, &ng_use2); if(ng_use1 < ng_use2) n_long = ng_use1; else n_long = ng_use2; i_result = tfni_compare_strings(psg_use1, psg_use2, n_long); if(i_result == 0 && ng_use1 != ng_use2) { i_result = ng_use1 - ng_use2; } free(psg_use1); psg_use1 = NULL; ng_use1 = 0; free(psg_use2); psg_use2 = NULL; ng_use2 = 0; /* ==,<<,<=,<>,>>,>= */ i_type = 0; if(psg_pline[11] == '=') i_type = 10; else if(psg_pline[11] == '<') i_type = 20; else if(psg_pline[11] == '>') i_type = 30; if(psg_pline[12] == '=') i_type = i_type + 1; else if(psg_pline[12] == '<') i_type = i_type + 2; else if(psg_pline[12] == '>') i_type = i_type + 3; ig_true = 2; /* == */ if(i_type == 11) { if(i_result == 0) ig_true = 1; } /* <= */ else if(i_type == 21) { if(i_result <= 0) ig_true = 1; } /* << */ else if(i_type == 22) { if(i_result < 0) ig_true = 1; } /* <> */ else if(i_type == 23) { if(i_result != 0) ig_true = 1; } /* >= */ else if(i_type == 31) { if(i_result >= 0) ig_true = 1; } /* >> */ else if(i_type == 33 && i_result > 0) ig_true = 1; /* ig_true=1 means true */ } /* sub_command_sift_swhi */ void sub_command_sinp(void) { /* updated 2011/09/26 */ /* 2008/05/06, 2005/09/07, 2005/03/12, 2005/02/23, 2004/11/25 */ /* 012345678901234567890 */ /* $inp S00001,"hello there" */ /* $inp S00001,S00002 */ /* from psg_pline fetch into psg_use1,ng_use1 */ sub_fetch_string_expression_use(12); tsub_out79(psg_use1, ng_use1); /* get term input into sg_pass, ng_pass_lg */ tsub_inp1024(); tsub_copy(sg_pass, sg_inp1024, ig_inp1024_lg); ng_pass_lg = ig_inp1024_lg; sub_store_string_in_link(sg_pass, ng_pass_lg); } /* sub_command_sinp */ void sub_command_sins(void) { /* updated 2006/10/21, 2005/07/17, 2005/05/12, 2005/04/06, 2005/04/05 */ /* 2005/04/04, 2005/03/12, 2005/02/21, 2005/02/19, 2004/12/08 */ /* 0123456789012345678901234 */ /* $ins S00001,D00001,S00002 */ long n_beg; int i_error = 2; /* get first string into psg_use2,ng_use2 */ sub_fetch_string3(5, &psg_use2, &ng_use2); /* get second string into psg_use3,ng_use3 */ sub_fetch_string3(19, &psg_use3, &ng_use3); /* get the insert byte into n_beg */ sub_fetch_decimal_variable_lng(&psg_pline[12]); n_beg = ng_pass_long; /* $INS */ if(n_beg < 1) n_beg = 1; if(n_beg > ng_use2) n_beg = ng_use2 + 1; n_beg--; if((ng_use2 + ng_use3) <= MAXSTRING) { /* insert string and put into sg_pass,ng_pass_lg */ tsub_use_insert321(n_beg); sub_store_string_in_link(psg_use1, ng_use1); } else i_error = 1; free(psg_use2); psg_use2 = NULL; free(psg_use3); psg_use3 = NULL; if(i_error == 1) sub_program_error_end("in $INS", 7); } /* sub_command_sins */ void sub_command_srep(void) { /* updated 2006/10/21, 2005/07/17, 2005/05/12, 2005/04/06, 2005/04/05 */ /* 2005/04/04, 2005/03/12, 2005/02/21, 2005/02/19, 2004/12/08 */ /* 0123456789012345678901234 */ /* $REP S00001,D00001,S00002 */ long n_beg; int i_error = 2; /* get second string into psg_use3,ng_use3 */ sub_fetch_string3(19, &psg_use3, &ng_use3); /* get the insert byte into n_beg */ sub_fetch_decimal_variable_lng(&psg_pline[12]); n_beg = ng_pass_long; /* get first string into psg_byref,ng_byref */ sub_fetch_string_byref(5); /* $REP */ n_beg--; if(n_beg >= 0 && (n_beg + ng_use3) <= ng_byref) { tsub_copy(&psg_byref[n_beg], psg_use3, ng_use3); } else i_error = 1; psg_byref = NULL; ng_byref = 0; free(psg_use3); psg_use3 = NULL; ng_use3 = 0; if(i_error == 1) sub_program_error_end("in $REP", 7); } /* sub_command_srep */ void sub_command_sisc(int ip1) { /* updated 2005/10/13, 2005/07/12 */ /* 2005/04/09, 2005/04/06, 2005/04/03, 2005/03/25, 2005/03/19 */ /* uses long strings */ /* 0123456789012345678901234 */ /* $ISC D12345,S12345,S12345 */ /* 1=$ISC */ /* 2=$IST */ /* 3=$ISP */ int i_yesno, i_type, ix, iy; long nz; /* get string to consider in psg_use1,ng_use1 */ sub_fetch_string3(12, &psg_use1, &ng_use1); /* get pattern string into psg_use2,ng_use2 */ sub_fetch_string3(19, &psg_use2, &ng_use2); i_yesno = 2; if(ip1 == 1) { /* $ISC string is a certain char */ for(iy = 1, nz = 0; iy == 1 && nz < ng_use1; nz++) { if(psg_use1[nz] != psg_use2[0]) iy++; } if(iy == 1) i_yesno = 1; } else if(ip1 == 2) { /* $IST string is a certain type */ i_type = tfni_char_type(psg_use2[0]); for(iy = 1, nz = 0; iy == 1 && nz < ng_use1; nz++) { ix = tfni_char_type(psg_use1[nz]); if(ix != i_type) iy++; } if(iy == 1) i_yesno = 1; } else if(ip1 == 3) { /* $ISP string is a certain pattern */ if(ng_use1 == ng_use2) { for(iy = 1, nz = 0; iy == 1 && nz < ng_use1; nz++) { i_type = tfni_char_type(psg_use1[nz]); ix = tfni_char_type(psg_use2[nz]); if(ix != i_type) iy++; } if(iy == 1) i_yesno = 1; } } if(ng_use1 == 0 || ng_use2 == 0) i_yesno = 2; free(psg_use1); psg_use1 = NULL; ng_use1 = 0; free(psg_use2); psg_use2 = NULL; ng_use2 = 0; dg_1pass = i_yesno; sub_store_decimal_variable_in_link(); } /* sub_command_sisc */ void sub_command_slen(int ip1) { /* updated 2011/08/25, 2006/06/02, 2006/05/31 */ /* 2005/10/12, 2005/07/04, 2005/03/12, 2005/02/21, 2004/12/03 */ /* uses long strings */ /* 0123456789012345 */ /* $len D0001,S0001 */ /* 1=$len, 2=$chd, 3=$hsh */ int iz; int i_error = 2; long nx, ny, nz; /* get string to find in */ sub_fetch_string3(12, &psg_use1, &ng_use1); if(ip1 == 1) { /* $LEN */ dg_1pass = ng_use1; } else if(ip1 == 2) { /* $CHD */ if(ng_use1 > 0) { iz = (int)psg_use1[0]; if(iz < 0) iz = iz + 256; dg_1pass = iz; } else i_error = 1; } else if(ip1 == 3) { /* $hsh */ nx = 0; ny = 0; for(nz = 0; nz < ng_use1; nz++) { iz = (int)psg_use1[nz] + 1; /* nx is just a total, 1,000,000,007 is prime */ nx = (nx + iz) % 1000000007; /* 701 is prime, 1,000,003 is prime */ ny = (ny + (nz % 701 + 1) * iz) % 1000003; } /* 1,000,033 is prime */ dg_1pass = (double)nx * 1000033 + ny; } else i_error = 1; free(psg_use1); psg_use1 = NULL; ng_use1 = 0; if(i_error != 1) sub_store_decimal_variable_in_link(); else sub_program_error_end("bad $chd", 8); } /* sub_command_slen */ void sub_command_slok(int ip1) { /* updated 2006/10/21, 2005/07/23 */ /* 2005/07/22, 2005/04/11, 2005/04/06, 2005/03/12, 2005/03/05 */ /* uses long strings */ /* 01234567890123456789012345678901 */ /* $LOK D00001,S00001,D00002,S00002 */ /* 1=$LOK, 2=$BAK */ int i_loop; long n_begin, n_result, n_max; long nx, ny, nz; /* where to begin */ sub_fetch_decimal_variable_lng(&psg_pline[19]); n_begin = ng_pass_long; /* get lookfor in psg_use2,ng_use2 */ sub_fetch_string3(26, &psg_use2, &ng_use2); /* string to look in is psg_use1,ng_use1 */ /* sub_fetch_string3(12, &psg_use1, &ng_use1); */ sub_fetch_string_byref(12); n_result = 0; /* look for cannot be longer than look in */ if(ng_use2 > ng_byref) ip1 = 9999; if(ip1 == 1) { /* $LOK */ i_loop = 1; if(n_begin < 1) n_begin = 1; n_begin--; /* get i_max = maximum possible find byte */ n_max = ng_byref - ng_use2; if(n_begin > n_max) i_loop++; nz = n_begin; while(i_loop == 1) { if(psg_byref[nz] == psg_use2[0]) { for(ny = 1, nx = 0; ny == 1 && nx < ng_use2; nx++) { if(psg_byref[nz + nx] != psg_use2[nx]) ny++; } if(ny == 1) { i_loop++; n_result = nz + 1; } } nz++; if(nz > n_max) i_loop++; } } else if(ip1 == 2) { /* $BAK */ i_loop = 1; if(n_begin > ng_byref) n_begin = ng_byref; n_begin--; /* get n_max = maximum possible find byte */ n_max = ng_byref - ng_use2; if(n_begin > n_max) n_begin = n_max; if(n_begin < 0) i_loop++; nz = n_begin; while(i_loop == 1) { if(psg_byref[nz] == psg_use2[0]) { for(ny = 1, nx = 0; ny == 1 && nx < ng_use2; nx++) { if(psg_byref[nz + nx] != psg_use2[nx]) ny++; } if(ny == 1) { i_loop++; n_result = nz + 1; } } nz--; if(nz < 0) i_loop++; } } psg_byref = NULL; ng_byref = 0; free(psg_use2); psg_use2 = NULL; ng_use2 = 0; dg_1pass = n_result; sub_store_decimal_variable_in_link(); } /* sub_command_slok */ void sub_command_sout(int ip1) { /* updated 2011/09/26, 2005/07/31, 2005/07/25, 2005/07/24, 2005/07/23 */ /* 2005/07/22, 2005/07/15, 2005/05/03, 2005/04/20, 2004/12/02 */ /* uses long strings */ /* 01234567890123456789 */ /* $out S00001+D00321+"hello there" */ /* $sho S00001 */ char sz[80]; /* from psg_pline fetch into psg_use1,ng_use1 */ sub_fetch_string_expression_use(5); if(ng_use1 > 79) ng_use1 = 79; tsub_blank(sz, 80); tsub_copy(sz, psg_use1, ng_use1); tsub_blank_escapes(sz, 80); sz[79] = 0; if(ip1 == 2) { /* ip1 = 2 is $SHO */ printf("%s\r", sz); fflush(stdout); } else { /* ip1 = 1 is $OUT */ printf("%s\n", sz); fflush(stdout); } free(psg_use1); psg_use1 = NULL; ng_use1 = 0; } /* sub_command_sout */ void sub_command_spkd(int ip1) { /* updated 2005/07/31, 2005/06/06, 2005/05/03 */ /* does not need long strings */ /* ip1=1 for $PKD */ /* ip1=2 for DPK$ */ /* ip1=3 for DTOF */ double d_decimal; int i_good, i_long, i_negative; int ix, iy, iz; if(ip1 == 1) { /* 0123456789012345678901234 */ /* $PKD D12345,D12345,S12345 */ /* get packed decimal number string */ sub_fetch_string_pass(19); tsub_pass_trim_left(); tsub_pass_trim_right(); /* if nothing make zero */ if(ng_pass_lg == 0) { sg_pass[0] = '0'; ng_pass_lg = 1; } /* get the last character and do we need to change it */ ix = ng_pass_lg - 1; iz = sg_pass[ix]; /* 48 is 0 and 57 is 9 */ i_negative = 1; if(iz >= 48 && iz <= 57) i_negative = 2; else if(iz >= 65 && iz <= 73) { /* 65 is A and 73 is I */ i_negative = 2; iz = iz - 16; sg_pass[ix] = (char)iz; } else if(iz >= 74 && iz <= 82) { /* 74 is J=1 and 82 is R=9 */ i_negative = 1; iz = iz - 25; sg_pass[ix] = (char)iz; } else if(iz == 125) { /* a right brace is 125 which is negative zero */ i_negative = 1; sg_pass[ix] = '0'; } else if(iz == 123) { /* a left brace is 123 which is positive zero */ i_negative = 2; sg_pass[ix] = '0'; } /* make sure we now have all digits and not too long */ d_decimal = 0; i_good = 1; if(ng_pass_lg > 15) i_good = 2; for(iz = 0; iz < ng_pass_lg; iz++) { iy = sg_pass[iz] - 48; if(iy < 0 || iy > 9) i_good = 2; else d_decimal = d_decimal * 10 + iy; } if(i_negative == 1) d_decimal = - d_decimal; if(i_good == 1) { dg_1pass = d_decimal; sub_store_decimal_variable(&psg_pline[12]); } dg_1pass = i_good; sub_store_decimal_variable_in_link(); } else if(ip1 == 2) { /* 0123456789012345678901234 */ /* DPK$ S12345,D12345,D12345 */ /* get decimal to make into packed decimal string */ sub_fetch_decimal_variable_1dbl(&psg_pline[12]); d_decimal = dg_1pass; i_negative = 2; if(d_decimal < 0) { i_negative = 1; d_decimal = - d_decimal; } /* 0.5 is too much for numbers close to 2^53 */ d_decimal = floor(d_decimal + 0.499); /* get length of string */ sub_fetch_decimal_variable_int(&psg_pline[19]); i_long = ig_pass_int; if(i_long < 0) i_good = 2; else i_good = 1; /* put right most digit in sg_buff1[29] zero filled */ sprintf(sg_buff1, "%030.0f", d_decimal); if(i_negative == 1) { /* put in right most digit to show negative */ iz = sg_buff1[29]; /* char 48 is a zero */ if(iz == 48) sg_buff1[29] = '}'; else { iz = iz + 25; sg_buff1[29] = (char)iz; } } iz = 29 - i_long + 1; tsub_copy(sg_pass, &sg_buff1[iz], i_long); ng_pass_lg = i_long; if(i_good == 1) sub_store_string_in_link(sg_pass, ng_pass_lg); else sub_program_error_end("$pkd", 4); } else if(ip1 == 3) { /* 0123456789012345678901234 */ /* DTOF S12345,D12345,D12345 */ /* get decimal to make into packed decimal string */ sub_fetch_decimal_variable_1dbl(&psg_pline[12]); d_decimal = dg_1pass; i_negative = 2; if(d_decimal < 0) { i_negative = 1; d_decimal = - d_decimal; } /* 0.5 is too much for numbers close to 2^53 */ d_decimal = floor(d_decimal + 0.499); /* get length of string */ sub_fetch_decimal_variable_int(&psg_pline[19]); i_long = ig_pass_int; if(i_long < 0) i_good = 2; else i_good = 1; /* put into sg_buff1 with the right most digit in sg_buff1[29] */ sprintf(sg_buff1, "%030.0f", d_decimal); iz = 29 - i_long + 1; if(i_negative == 1) sg_buff1[iz] = '-'; else sg_buff1[iz] = '+'; tsub_copy(sg_pass, &sg_buff1[iz], i_long); ng_pass_lg = i_long; if(i_good == 1) sub_store_string_in_link(sg_pass, ng_pass_lg); else sub_program_error_end("$tof", 4); } } /* sub_command_spkd */ void sub_command_spar(void) { /* updated 2010/06/03 */ /* 2006/10/23, 2006/04/13, 2005/07/19, 2005/04/06, 2005/04/01 */ /* uses long strings */ /* 01234567890123456789012345678901 */ /* $PAR S12345,S12345,S12345,D12345 */ char c_csv; long n_which, n_beg, n_count, ny, nz; int i_good = 1; /* get the number of which one we want into n_which */ sub_fetch_decimal_variable_lng(&psg_pline[26]); n_which = ng_pass_long; if(n_which < 1) i_good++; /* put the one length csv delimiter into c_csv */ sub_fetch_string3(19, &psg_use3, &ng_use3); c_csv = psg_use3[0]; if(ng_use3 <= 0) i_good++; if(i_good == 1) { /* reference look-in string with psg_byref,ng_byref */ sub_fetch_string_byref(12); if(ng_byref < 2) i_good++; } if(i_good == 1) { /* find the beginning of one we want into n_beg */ if(n_which == 1) n_beg = 0; else { n_beg = -1; n_count = 1; for(nz = 0; n_beg == -1 && nz < ng_byref; nz++) { if(psg_byref[nz] == c_csv) { n_count++; if(n_count == n_which) n_beg = nz + 1; } } } if(n_beg < 0 || n_beg >= ng_byref) i_good++; } if(i_good == 1) { /* how long into ng_use1 */ ny = 1; ng_use1 = 0; for(nz = n_beg; ny == 1 && nz < ng_byref; nz++) { if(psg_byref[nz] == c_csv) { ng_use1 = nz - n_beg; ny++; } } if(ny == 1) { /* string ends at end of in-string */ ng_use1 = ng_byref - n_beg; } } if(i_good != 1) ng_use1 = 0; tsub_make_long_string(&psg_use1, ng_use1); if(i_good == 1) { /* copy the one wanted to psg_use1,ng_use1 */ tsub_copy(psg_use1, &psg_byref[n_beg], ng_use1); } sub_store_string_in_link(psg_use1, ng_use1); } /* sub_command_spar */ void sub_command_sdot(void) { /* updated 2006/10/23, 2006/05/12 */ /* find location of certain occurrence of a string in a string */ /* 01234567890123456789012345678901 */ /* $DOT N12345,S12345,S12345,D12345 */ char c_csv; long n_which, n_last, n_count, ny, nz; long n_dot = 0; int i_good = 1; /* get which one we want into n_which */ sub_fetch_decimal_variable_lng(&psg_pline[26]); n_which = ng_pass_long; /* get string parameters */ sub_fetch_string3(19, &psg_use3, &ng_use3); sub_fetch_string_byref(12); /* get first byte of psg_use3,ng_use3 */ c_csv = psg_use3[0]; /* both must have length */ if(ng_byref <= 0) i_good++; if(ng_use3 <= 0) i_good++; if(n_which <= 0) i_good++; if(i_good == 1) { n_last = ng_byref - ng_use3 + 1; n_count = 0; for(nz = 0; nz < n_last; nz++) { if(psg_byref[nz] == c_csv) { ny = tfni_compare_strings(&psg_byref[nz], psg_use3, ng_use3); if(ny == 0) { /* we have a match */ n_count++; if(n_count == n_which) { /* we have the wanted count */ n_dot = nz; nz = n_last; } else { nz = nz + ng_use3; } } } } } dg_1pass = n_dot + 1; sub_store_decimal_variable_in_link(); } /* sub_command_sdot */ void sub_command_stoe(void) { /* updated 2006/08/22, 2006/08/21, 2006/04/08 */ /* $toe old toe */ /* 01234567890123456789012345678901 */ /* $TOE S12345,S12345,S12345,D12345 */ long n_number, n_byte, n_slip, n_which, ny, nz; long n_bigprime = 700000001; /* 700,000,001 */ /* get key string into psg_use3,ng_use3 */ sub_fetch_string3(19, &psg_use3, &ng_use3); /* put begin string into psg_use2,ng_use2 */ sub_fetch_string3(12, &psg_use2, &ng_use2); /* get which one we want into n_which */ sub_fetch_decimal_variable_lng(&psg_pline[26]); n_which = ng_pass_long; if(n_which != 1) n_which = 2; /* get n_number from psg_use3,ng_use3 */ tsub_case_upper(psg_use3, ng_use3); n_number = 0; if(ng_use3 > 16) ng_use3 = 16; for(nz = 0; nz < ng_use3; nz++) { ny = psg_use3[nz]; if((ny >= '0' && ny <= '9') || (ny >= 'A' && ny <= 'Z')) n_number = n_number * 10 + ny; if(n_number > n_bigprime) n_number = n_number - n_bigprime; } for(n_byte = 0; n_byte < ng_use2; n_byte++) { /* get next n_number */ n_number = (n_number * 3 + 35731) % n_bigprime; n_slip = (n_number / 103) % 95 + 1; ny = psg_use2[n_byte]; if(ny >= 32 && ny <= 126) { if(n_which == 1) ny = ny + n_slip; else ny = ny - n_slip; if(ny > 126) ny = ny - 95; else if(ny < 32) ny = ny + 95; psg_use2[n_byte] = (char)ny; } } sub_store_string_in_link(psg_use2, ng_use2); } /* sub_command_stoe */ void sub_command_sset(void) { /* updated 2011/09/26, 2005/07/21, 2005/03/12, 2004/11/27 */ /* uses long strings */ /* 012345678901234567 */ /* $set S00001=S00002 */ /* $set S00001="hello there" */ /* from psg_pline fetch into psg_use1,ng_use1 */ sub_fetch_string_expression_use(12); sub_store_string_in_link(psg_use1, ng_use1); } /* sub_command_sset */ void sub_command_ssor(void) { /* updated 2005/07/23, 2005/07/22, 2005/04/12, 2005/04/03, 2005/04/02 */ /* uses long strings */ /* 0123456789012345678901234 */ /* $SOR S00001,S00002,D00001 */ int i_process; long n_long, n_max, nz; long n_part1, n_part2, n_byte1, n_byte2; i_process = 1; /* the the length of the sort part */ sub_fetch_decimal_variable_lng(&psg_pline[19]); n_long = ng_pass_long; /* put string to be sorted into psg_use1,ng_use1 */ sub_fetch_string3(12, &psg_use1, &ng_use1); /* make a swap string n_long */ tsub_make_long_string(&psg_use2, n_long); if(ng_use1 < n_long) i_process++; if(n_long > 0) { nz = ng_use1 % n_long; if(nz != 0) i_process++; } else i_process++; if(i_process == 1) { n_max = ng_use1 / n_long; for(n_part1 = 1; n_part1 < n_max; n_part1++) { n_byte1 = (n_part1 - 1) * n_long; for(n_part2 = n_part1 + 1; n_part2 <= n_max; n_part2++) { n_byte2 = (n_part2 - 1) * n_long; nz = tfni_compare_strings( &psg_use1[n_byte1], &psg_use1[n_byte2], n_long); /* first is greater so swap */ if(nz > 0) { tsub_copy(psg_use2, &psg_use1[n_byte1], n_long); tsub_copy(&psg_use1[n_byte1], &psg_use1[n_byte2], n_long); tsub_copy(&psg_use1[n_byte2], psg_use2, n_long); } } } } if(i_process == 1) sub_store_string_in_link(psg_use1, ng_use1); free(psg_use1); psg_use1 = NULL; ng_use1 = 0; free(psg_use2); psg_use2 = NULL; ng_use2 = 0; } /* sub_command_ssor */ void sub_command_stod(int ip1) { /* updated 2005/03/12, 2004/11/30 */ /* does not need long strings */ /* 012345678901234567 */ /* $tod D00012,S00001 */ /* $tod D00004,"12345.6789" */ sub_fetch_string_pass(12); tsub_string_to_double(sg_pass, ng_pass_lg); /* ip1=1 is $tod, ip1=2 is $isd */ if(ip1 == 2) dg_1pass = ig_pass_int; sub_store_decimal_variable_in_link(); } /* sub_command_stod */ void sub_command_stoi(int ip1) { /* updated 2005/07/23, 2005/04/14, 2005/04/09, 2005/03/31, 2005/03/12 */ /* uses long strings */ /* 012345678901234567 */ /* $TOI D12345,S12345 = 1 */ /* Ito$ S12345,D12345 = 2 */ /* ARRB = 3 */ /* ARRZ = 4 */ int i_index; if(ip1 == 1) { /* $TOI */ sub_fetch_decimal_variable_int(&psg_pline[5]); i_index = ig_pass_int - 1; if(i_index >= 0 && i_index < SARRAY) { /* from psg_pline fetch into psg_use1,ng_use1 */ sub_fetch_string_expression_use(12); tsub_make_long_string(&psga_sarray[i_index], ng_use1); tsub_copy(psga_sarray[i_index], psg_use1, ng_use1); iga_sarray_lg[i_index] = ng_use1; } else sub_program_error_end("$TOI bad index", 14); } else if(ip1 == 2) { /* ITO$ */ sub_fetch_decimal_variable_int(&psg_pline[12]); i_index = ig_pass_int - 1; if(i_index >= 0 && i_index < SARRAY) { ng_use1 = iga_sarray_lg[i_index]; tsub_make_long_string(&psg_use1, ng_use1); tsub_copy(psg_use1, psga_sarray[i_index], ng_use1); sub_store_string_in_link(psg_use1, ng_use1); } else sub_program_error_end("ITO$ bad index", 14); } else if(ip1 == 3) { /* ARRB */ /* free memory of psga_sarray */ for(i_index = 0; i_index < SARRAY; i_index++) { free(psga_sarray[i_index]); psga_sarray[i_index] = NULL; iga_sarray_lg[i_index] = 0; } } else if(ip1 == 4) { for(i_index = 0; i_index < DARRAY; i_index++) dga_darray[i_index] = 0; } } /* sub_command_stoi */ void sub_command_strl(int ip1) { /* updated 2006/03/17, 2006/01/17, 2005/10/12 */ /* 2005/08/16, 2005/07/17, 2005/03/12, 2005/02/21, 2005/02/20 */ /* uses long strings */ /* 012345678901234567 */ /* $trl s12345,s12345 */ /* 1=$TRL, 2=$TRR, 3=$TRB, 4=$BES, 5=$CLO, 6=$CUP */ /* 7=$TLO, 8=$TUP, 9=$COD, 10=$TOE */ int i_error = 2; int i_char; long nz; /* get the string into psg_use2,ng_use2 */ sub_fetch_string3(12, &psg_use2, &ng_use2); if(ip1 == 1) { /* $TRL */ /* trim left into psg_use1,ng_use1 */ tsub_use_trim_left(psg_use2, ng_use2); } else if(ip1 == 2) { /* $TRR */ /* trim right into psg_use1,ng_use1 */ tsub_use_trim_right(psg_use2, ng_use2); } else if(ip1 == 3) { /* $TRB */ /* trim left into psg_use1,ng_use1 */ tsub_use_trim_left(psg_use2, ng_use2); tsub_use_move12(); /* trim right into psg_use1,ng_use1 */ tsub_use_trim_right(psg_use2, ng_use2); } else if(ip1 == 4) { /* $BES */ tsub_blank_escapes(psg_use2, ng_use2); tsub_use_move21(); } else if(ip1 == 5) { /* $CLO */ tsub_case_lower(psg_use2, ng_use2); tsub_use_move21(); } else if(ip1 == 6) { /* $CUP */ tsub_case_upper(psg_use2, ng_use2); tsub_use_move21(); } else if(ip1 == 7) { /* $TLO */ tsub_case_lower(psg_use2, ng_use2); tsub_use_trim_left(psg_use2, ng_use2); tsub_use_move12(); tsub_use_trim_right(psg_use2, ng_use2); } else if(ip1 == 8) { /* $TUP */ tsub_case_upper(psg_use2, ng_use2); tsub_use_trim_left(psg_use2, ng_use2); tsub_use_move12(); tsub_use_trim_right(psg_use2, ng_use2); } else if(ip1 == 9) { /* $COD */ for(nz = 0; nz < ng_use2; nz++) { i_char = psg_use2[nz]; if(i_char > 32 && i_char < 127) { i_char = i_char + 47; if(i_char > 126) i_char = i_char - 94; psg_use2[nz] = (char)i_char; } } tsub_use_move21(); } else if(ip1 == 10) { /* $TOE */ for(nz = 0; nz < ng_use2; nz++) { i_char = psg_use2[nz]; if(i_char > 32 && i_char < 127) { i_char = 159 - i_char; psg_use2[nz] = (char)i_char; } } tsub_use_move21(); } else i_error++; if(i_error != 1) sub_store_string_in_link(psg_use1, ng_use1); free(psg_use1); psg_use1 = NULL; ng_use1 = 0; } /* sub_command_strl */ void sub_command_sswp(void) { /* updated 2010/05/21, 2008/02/11, 2008/10/02, 2006/08/09, 2005/07/23 */ /* 2005/06/05, 2005/04/07, 2005/04/06, 2005/04/03, 2005/04/02 */ /* 0123456789012345678901234 */ /* $swp S12345,S12345,S12345 */ /* $swp s_string, s_old, s_new */ int i_error, i_loop, iy; long n1, n2; /* put swapout string in psg_use3,ng_use3 */ sub_fetch_string3(12, &psg_use3, &ng_use3); /* put swapin string in psg_use4,ng_use4 */ sub_fetch_string3(19, &psg_use4, &ng_use4); /* get main string to make changes to into psg_use2,ng_use2 */ sub_fetch_string3(5, &psg_use2, &ng_use2); /* find suitable length ng_use1 for result string */ if(ng_use4 <= ng_use3) ng_use1 = ng_use2 + 50; else ng_use1 = ng_use2 / 2 + ng_use2 + 50; if(ng_use2 == 0) ng_use1 = 0; /* make new string to put new main into in psg_use1,ng_use1 */ tsub_make_long_string(&psg_use1, ng_use1); tsub_blank(psg_use1, ng_use1); i_error = 2; n1 = 0; n2 = 0; i_loop = 1; /* if the main string is zero length then same output string */ if(ng_use2 == 0) i_loop++; /* if the swapout string is zero long */ if(ng_use3 == 0) { tsub_copy(psg_use1, psg_use2, ng_use2); ng_use1 = ng_use2; i_loop++; } while(i_loop == 1) { if(psg_use2[n2] != psg_use3[0]) { /* no match on zero byte so copy byte to new */ psg_use1[n1] = psg_use2[n2]; } else { /* does psg_use2 at n2 match the swapout string psg_use3 */ iy = tfni_compare_strings(&psg_use2[n2], psg_use3, ng_use3); if(iy == 0) { /* we have a match so swap */ tsub_copy(&psg_use1[n1], psg_use4, ng_use4); /* skip to end of in swapped string */ n2 = n2 + ng_use3 - 1; n1 = n1 + ng_use4 - 1; } else psg_use1[n1] = psg_use2[n2]; } n1++; n2++; if(n2 >= ng_use2) i_loop++; if(n1 >= ng_use1) { sub_program_error_end("too long swp", 12); i_loop++; } } ng_use1 = n1; /* store the new main string in psg_use1,ng_use1 */ if(i_error != 1) sub_store_string_in_link(psg_use1, ng_use1); free(psg_use1); psg_use1 = NULL; ng_use1 = 0; free(psg_use2); psg_use2 = NULL; ng_use2 = 0; free(psg_use3); psg_use3 = NULL; ng_use3 = 0; free(psg_use4); psg_use4 = NULL; ng_use4 = 0; } /* sub_command_sswp */ void sub_command_ssys(void) { /* updated 2011/09/26, 2007/12/14, 2006/08/29, 2005/03/31 */ /* 012345678901234567 */ /* $sys S12345,D12345 */ char s_string[100]; int i_parm2, iy, iz; sub_fetch_decimal_variable_int(&psg_pline[12]); i_parm2 = ig_pass_int; if(i_parm2 == 1) { /* path of current application */ tsub_copy(sg_pass, sg_path, ig_path); ng_pass_lg = ig_path; } else if(i_parm2 == 2) { /* name of current subroutine */ tsub_copy(sg_pass, "no subr", 7); ng_pass_lg = 7; for(iz = ig_pline_ix; iz > 0; iz--) { iy = iga_plines_lg[iz]; tsub_copy(s_string, psga_plines[iz], iy); if(tfni_compare_strings(s_string, "SUBR", 4) == 0) { tsub_copy(sg_pass, &s_string[5], iy - 5); ng_pass_lg = iy - 5; iz = 0; } } } else if(i_parm2 == 3) { /* name of version */ tsub_copy(sg_pass, sg_version, 60); ng_pass_lg = 60; } else if(i_parm2 == 4) { /* name of load program */ tsub_copy(sg_pass, sg_loadprogram, ig_loadprogram); ng_pass_lg = ig_loadprogram; } sub_store_string_in_link(sg_pass, ng_pass_lg); } /* sub_command_ssys */ /* command subroutines above */ /* fetch and store subroutines below */ void sub_fetch_decimal_variable_1dbl(char *sp_var) { /* updated 2009/03/08 */ /* 2008/07/19, 2008/07/15, 2008/07/14, 2008/07/09, 2008/02/02 */ /* 2006/03/01, 2006/02/28, 2005/11/30, 2005/07/31, 2005/03/13 */ /* 2005/03/12, 2005/02/18, 2005/02/17, 2005/02/01, 2004/12/04 */ /* 012456 */ /* D12345 */ int i_index; /* fetch/store use sg_pass, ng_pass_lg, dg_1pass */ /* char 48 is zero */ /* i_index = tfni_string_to_integer(&sp_var[1], 5); */ i_index = sp_var[1] * 10000 + sp_var[2] * 1000 + sp_var[3] * 100 + sp_var[4] * 10 + sp_var[5] - 533328; /* D means global, E means local, F means constant, N means number */ /* N means number */ if(sp_var[0] == 'N') dg_1pass = i_index; else if(sp_var[0] == 'E') { /* local */ dg_1pass = dga_decimals[i_index + ig_dvstack_ct]; } else if(sp_var[0] == 'D') { /* global */ dg_1pass = dga_decimals[i_index]; } else if(sp_var[0] == 'F') { /* stored decimal literal */ dg_1pass = dga_decimals[i_index]; } /* negative number */ else if(sp_var[0] == 'M') dg_1pass = -i_index; else sub_program_error_end("bad dec var", 11); } /* sub_fetch_decimal_variable_1dbl */ void sub_fetch_decimal_variable_2dbl(char *sp_var) { /* updated 2009/03/08 */ /* 2008/07/19, 2008/07/15, 2008/07/14, 2008/07/08, 2008/02/02 */ /* 2006/03/01, 2006/02/28, 2005/11/30, 2005/07/31, 2005/03/13 */ /* 2005/03/12, 2005/02/18, 2005/02/17, 2005/02/01, 2004/12/04 */ /* 012456 */ /* D12345 */ int i_index; /* fetch/store use sg_pass, ng_pass_lg, dg_2pass */ /* char 48 is zero */ /* i_index = tfni_string_to_integer(&sp_var[1], 5); */ i_index = sp_var[1] * 10000 + sp_var[2] * 1000 + sp_var[3] * 100 + sp_var[4] * 10 + sp_var[5] - 533328; /* D means global, E means local, F means constant, N means number */ /* N means positive integer */ if(sp_var[0] == 'N') dg_2pass = i_index; else if(sp_var[0] == 'E') { /* local */ dg_2pass = dga_decimals[i_index + ig_dvstack_ct]; } else if(sp_var[0] == 'D') { /* global */ dg_2pass = dga_decimals[i_index]; } else if(sp_var[0] == 'F') { /* stored decimal literal */ dg_2pass = dga_decimals[i_index]; } /* negative number */ else if(sp_var[0] == 'M') dg_2pass = -i_index; else sub_program_error_end("bad dec var", 11); } /* sub_fetch_decimal_variable_2dbl */ void sub_fetch_decimal_pointer_dbl(char *sp_var, double *dp_var) { /* updated 2008/02/02 */ /* 2006/03/01, 2006/02/28, 2005/11/30, 2005/07/31, 2005/03/13 */ /* 2005/03/12, 2005/02/18, 2005/02/17, 2005/02/01, 2004/12/04 */ /* 01245 */ /* D1234 */ int i_index; int i_error = 2; /* this sub is currently not used */ *dp_var = 0; /* fetch/store use sg_pass, ng_pass_lg, dp_var */ /* char 48 is zero */ /* i_index = tfni_string_to_integer(&sp_var[1], 5); */ i_index = sp_var[1] * 10000 + sp_var[2] * 1000 + sp_var[3] * 100 + sp_var[4] * 10 + sp_var[5] - 533328; /* D means global, E means local, F means constant, N means number */ if(sp_var[0] == 'D') { /* global */ if(i_index >= 0 && i_index < VDECIMALS) *dp_var = dga_decimals[i_index]; else i_error = 1; } else if(sp_var[0] == 'E') { /* local */ i_index = i_index + ig_dvstack_ct; if(i_index >= 0 && i_index < VDECIMALS) *dp_var = dga_decimals[i_index]; else i_error = 1; } else if(sp_var[0] == 'F') { /* stored decimal literal */ if(i_index >= 0 && i_index < VDECIMALS) *dp_var = dga_decimals[i_index]; else i_error = 1; } /* number */ else if(sp_var[0] == 'N') *dp_var = i_index; else if(sp_var[0] == 'M') *dp_var = -i_index; else i_error = 1; if(i_error == 1) sub_program_error_end("bad dec var", 11); } /* sub_fetch_decimal_pointer_dbl */ void sub_fetch_decimal_variable_lng(char *sp_var) { /* updated 2009/03/14, 2008/02/02 */ /* 2006/03/01, 2006/02/28, 2005/11/30, 2005/07/31, 2005/03/13 */ /* 2005/03/12, 2005/02/18, 2005/02/17, 2005/02/01, 2004/12/04 */ /* 01245 */ /* D1234 */ int i_index; double dz; /* fetch/store use sg_pass, ng_pass_lg, dg_1pass */ /* char 48 is zero */ /* i_index = tfni_string_to_integer(&sp_var[1], 5); */ i_index = sp_var[1] * 10000 + sp_var[2] * 1000 + sp_var[3] * 100 + sp_var[4] * 10 + sp_var[5] - 533328; /* D means global, E means local, F means constant, N means number */ if(sp_var[0] == 'D') { /* global */ dz = dga_decimals[i_index]; } else if(sp_var[0] == 'E') { /* local */ dz = dga_decimals[i_index + ig_dvstack_ct]; } else if(sp_var[0] == 'F') { /* stored decimal literal */ dz = dga_decimals[i_index]; } /* number */ else if(sp_var[0] == 'N') dz = i_index; else if(sp_var[0] == 'M') dz = -i_index; /* get ng_pass_long from dz */ if(dz > 2147483647) dz = 2147483647; else if(dz < -2147483647) dz = -2147483647; /* 0.5 is too much for numbers close to 2^53 */ ng_pass_long = (long)floor(dz + 0.499); } /* sub_fetch_decimal_variable_lng */ void sub_fetch_decimal_variable_int(char *sp_var) { /* updated 2009/03/14, 2008/02/02 */ /* 2006/03/01, 2006/02/28, 2005/11/30, 2005/07/31, 2005/03/13 */ /* 2005/03/12, 2005/02/18, 2005/02/17, 2005/02/01, 2004/12/04 */ /* 01245 */ /* D1234 */ int i_index; double dz; /* fetch/store use sg_pass, ng_pass_lg, dg_1pass */ /* char 48 is zero */ /* i_index = tfni_string_to_integer(&sp_var[1], 5); */ i_index = sp_var[1] * 10000 + sp_var[2] * 1000 + sp_var[3] * 100 + sp_var[4] * 10 + sp_var[5] - 533328; /* D means global, E means local, F means constant, N means number */ if(sp_var[0] == 'D') { /* global */ dz = dga_decimals[i_index]; } else if(sp_var[0] == 'E') { /* local */ dz = dga_decimals[i_index + ig_dvstack_ct]; } else if(sp_var[0] == 'F') { /* stored decimal literal */ dz = dga_decimals[i_index]; } /* number */ else if(sp_var[0] == 'N') dz = i_index; else if(sp_var[0] == 'M') dz = -i_index; /* get ig_pass_int from dz */ if(dz > 32767) dz = 32767; else if(dz < -32767) dz = -32767; /* 0.5 is too much for numbers close to 2^53 */ ig_pass_int = (int)floor(dz + 0.499); } /* sub_fetch_decimal_variable_int */ void sub_store_decimal_variable(char *sp_var) { /* updated 2009/03/14 */ /* 2008/02/02, 2005/06/08, 2005/03/12, 2005/02/01, 2004/11/27 */ /* 012345 */ /* D00001 */ int i_index; /* fetch/store use sg_pass, ng_pass_lg, dg_1pass */ /* char 48 is zero */ /* i_index = tfni_string_to_integer(&sp_var[1], 5); */ i_index = sp_var[1] * 10000 + sp_var[2] * 1000 + sp_var[3] * 100 + sp_var[4] * 10 + sp_var[5] - 533328; /* D means global decimal, E means local decimal */ if(sp_var[0] == 'D') { /* global */ dga_decimals[i_index] = dg_1pass; } else if(sp_var[0] == 'E') { /* local */ dga_decimals[i_index + ig_dvstack_ct] = dg_1pass; } } /* sub_store_decimal_variable */ void sub_store_decimal_variable_in_link(void) { /* updated 2009/03/14, 2008/02/10, 2008/01/07, 2007/11/10 */ /* 2007/11/06, 2005/06/08, 2005/03/12, 2005/02/01, 2004/11/27 */ /* 012345 */ /* D00001 */ long n_index; /* 01234567890 */ /* DSET E12345 */ /* D means global decimal, E means local decimal */ if(psg_pline[5] == 'E') n_index = ig_link_ix + ig_dvstack_ct; else n_index = ig_link_ix; dga_decimals[n_index] = dg_1pass; } /* sub_store_decimal_variable_in_link */ void sub_fetch_string_expression_use(int ip_byte) { /* updated 2011/09/26, 2011/05/03, 2005/12/05 */ /* 2005/12/02, 2005/07/23, 2005/07/21, 2005/07/20, 2005/06/07 */ /* 2005/04/12, 2005/03/12, 2005/02/19, 2005/02/06, 2004/11/27 */ /* evaluate string expression in psg_pline,ig_pline_lg beginning at ip_byte */ /* put string in psg_use1,ng_use1 */ /* 01234567890123 */ /* S0123+"hello there"+D0032+S0034 */ int i_loop, i_byte; long n_long; int i_error = 2; char cz; /* tsub_make_long_string(&psg_use2, ng_use2); */ free(psg_use1); psg_use1 = NULL; ng_use1 = 0; n_long = 0; i_byte = ip_byte; i_loop = 1; while(i_loop == 1) { cz = psg_pline[i_byte]; /* fetch/store use sg_pass, ng_pass_lg, dg_1pass */ if(cz == 'S' || cz == 'T' || cz == 'U' || cz == 'D' || cz == 'E' || cz == 'F' || cz == 'C' || cz == 'N' || cz == 'M') { /* global string variable */ sub_fetch_string3(i_byte, &psg_use3, &ng_use3); n_long = n_long + ng_use3; if(n_long <= MAXSTRING) { tsub_use_move12(); ng_use1 = n_long; tsub_make_long_string(&psg_use1, ng_use1); if(ng_use2 > 0) tsub_copy(psg_use1, psg_use2, ng_use2); tsub_copy(&psg_use1[ng_use2], psg_use3, ng_use3); i_byte = i_byte + 7; } else i_error = 1; } else i_loop++; if(i_byte >= ig_pline_lg) i_loop++; if(psg_pline[i_byte - 1] == ';') i_loop++; if(i_error == 1) i_loop++; } free(psg_use2); psg_use2 = NULL; ng_use2 = 0; free(psg_use3); psg_use3 = NULL; ng_use3 = 0; if(i_error == 1) { printf("length=%ld\n", n_long); sub_program_error_end("$expression too long", 20); } } /* sub_fetch_string_expression_use */ void sub_fetch_string_pass(int ip_byte) { /* updated 2005/12/10, 2005/12/05 */ /* 2005/11/30, 2005/06/07, 2005/06/01, 2005/03/12, 2005/02/21 */ /* fetch string in psg_pline,ig_pline_lg at ip_byte */ /* and put into sg_pass,ng_pass_lg */ /* 012345 */ /* S12345 */ int i_index; int i_error = 2; char cz; /* vslong is 8096 */ /* fetch/store use sg_pass, ng_pass_lg, dg_1pass */ /* fetch/store use psg_use1,ng_use1, dg_1pass */ /* char 48 is zero */ cz = psg_pline[ip_byte]; i_index = tfni_string_to_integer(&psg_pline[ip_byte + 1], 5); if(cz == 'S') { /* global string variable */ if(i_index >= 0 && i_index < VSTRINGS) { ng_pass_lg = nga_strings_lg[i_index]; if(ng_pass_lg <= VSLONG) { tsub_copy(sg_pass, psga_strings[i_index], ng_pass_lg); } else i_error = 1; } else i_error = 1; } else if(cz == 'T') { /* local string variable */ i_index = i_index + ig_svstack_ct; if(i_index >= 0 && i_index < VSTRINGS) { ng_pass_lg = nga_strings_lg[i_index]; if(ng_pass_lg <= VSLONG) { tsub_copy(sg_pass, psga_strings[i_index], ng_pass_lg); } else i_error = 1; } else i_error = 1; } else if(cz == 'U') { /* stored string literal */ if(i_index >= 0 && i_index < VSTRINGS) { ng_pass_lg = nga_strings_lg[i_index]; if(ng_pass_lg <= VSLONG) { tsub_copy(sg_pass, psga_strings[i_index], ng_pass_lg); } else i_error = 1; } else i_error = 1; } else if(cz == 'D') { /* global decimal variable */ if(i_index >= 0 && i_index < VDECIMALS) { dg_1pass = dga_decimals[i_index]; tsub_double_to_string(); } else i_error = 1; } else if(cz == 'E') { /* local decimal variable */ i_index = i_index + ig_dvstack_ct; if(i_index >= 0 && i_index < VDECIMALS) { dg_1pass = dga_decimals[i_index]; tsub_double_to_string(); } else i_error = 1; } else if(cz == 'F') { /* stored decimal literal */ if(i_index >= 0 && i_index < VDECIMALS) { dg_1pass = dga_decimals[i_index]; tsub_double_to_string(); } else i_error = 1; } else if(cz == 'C') { /* single character literal */ if(i_index >= 0 && i_index < 256) { ng_pass_lg = 1; sg_pass[0] = (char)i_index; } else i_error = 1; } else if(cz == 'N') { /* positive numeric literal */ dg_1pass = i_index; tsub_double_to_string(); } else if(cz == 'M') { /* negative numeric literal */ dg_1pass = -i_index; tsub_double_to_string(); } else i_error = 1; if(i_error == 1) sub_program_error_end("string int bad", 14); } /* sub_fetch_string_pass */ void sub_fetch_string_byref(int ip_byte) { /* updated 2006/10/11, 2005/12/10, 2005/12/05 */ /* 2005/11/30, 2005/06/07, 2005/06/01, 2005/03/12, 2005/02/21 */ /* fetch string in psg_pline,ig_pline_lg at ip_byte */ /* and point at with psg_byref,ng_byref or put in sg_byref */ /* 012345 */ /* S12345 */ int i_index; int i_error = 2; char cz; /* vslong is 8096 */ /* fetch/store use sg_pass, ng_pass_lg, dg_1pass */ /* fetch/store use psg_use1,ng_use1, dg_1pass */ /* char 48 is zero */ ng_byref = 0; psg_byref = NULL; cz = psg_pline[ip_byte]; i_index = tfni_string_to_integer(&psg_pline[ip_byte + 1], 5); if(cz == 'S') { /* global string variable */ if(i_index >= 0 && i_index < VSTRINGS) { ng_byref = nga_strings_lg[i_index]; if(ng_byref <= MAXSTRING) { psg_byref = psga_strings[i_index]; } else i_error = 1; } else i_error = 1; } else if(cz == 'T') { /* local string variable */ i_index = i_index + ig_svstack_ct; if(i_index >= 0 && i_index < VSTRINGS) { ng_byref = nga_strings_lg[i_index]; if(ng_byref <= MAXSTRING) { psg_byref = psga_strings[i_index]; } else i_error = 1; } else i_error = 1; } else if(cz == 'U') { /* stored string literal */ if(i_index >= 0 && i_index < VSTRINGS) { ng_byref = nga_strings_lg[i_index]; if(ng_byref <= MAXSTRING) { psg_byref = psga_strings[i_index]; } else i_error = 1; } else i_error = 1; } else if(cz == 'D') { /* global decimal variable */ if(i_index >= 0 && i_index < VDECIMALS) { dg_1pass = dga_decimals[i_index]; tsub_double_to_string(); tsub_copy(sg_byref, sg_pass, ng_pass_lg); psg_byref = sg_byref; ng_byref = ng_pass_lg; } else i_error = 1; } else if(cz == 'E') { /* local decimal variable */ i_index = i_index + ig_dvstack_ct; if(i_index >= 0 && i_index < VDECIMALS) { dg_1pass = dga_decimals[i_index]; tsub_double_to_string(); tsub_copy(sg_byref, sg_pass, ng_pass_lg); psg_byref = sg_byref; ng_byref = ng_pass_lg; } else i_error = 1; } else if(cz == 'F') { /* stored decimal literal */ if(i_index >= 0 && i_index < VDECIMALS) { dg_1pass = dga_decimals[i_index]; tsub_double_to_string(); tsub_copy(sg_byref, sg_pass, ng_pass_lg); psg_byref = sg_byref; ng_byref = ng_pass_lg; } else i_error = 1; } else if(cz == 'C') { /* single character literal */ if(i_index >= 0 && i_index < 256) { ng_pass_lg = 1; sg_byref[0] = (char)i_index; psg_byref = sg_byref; ng_byref = 1; } else i_error = 1; } else if(cz == 'N') { /* positive numeric literal */ dg_1pass = i_index; tsub_double_to_string(); tsub_copy(sg_byref, sg_pass, ng_pass_lg); psg_byref = sg_byref; ng_byref = ng_pass_lg; } else if(cz == 'M') { /* negative numeric literal */ dg_1pass = -i_index; tsub_double_to_string(); tsub_copy(sg_byref, sg_pass, ng_pass_lg); psg_byref = sg_byref; ng_byref = ng_pass_lg; } else i_error = 1; if(i_error == 1) sub_program_error_end("string_byref bad", 16); } /* sub_fetch_string_byref */ void sub_fetch_string3(int ip_byte, char **psp_1, long *pnp_long) { /* updated 2005/12/05, 2005/11/30, 2005/07/21 */ /* 2005/06/26, 2005/06/07, 2005/06/01, 2005/03/12, 2005/02/21 */ /* evaluate string var_lit into *psp_1,*pnp_long at ip_byte */ /* 012345 */ /* S12345 */ int i_index, i_beg; int i_error = 2; long n_long; char cz; /* char 48 is zero */ cz = psg_pline[ip_byte]; i_beg = ip_byte + 1; if(cz == 'S') { /* global string variable */ i_index = tfni_string_to_integer(&psg_pline[i_beg], 5); if(i_index >= 0 && i_index < VSTRINGS) { n_long = nga_strings_lg[i_index]; tsub_make_long_string(psp_1, n_long); tsub_copy(*psp_1, psga_strings[i_index], n_long); *pnp_long = n_long; } else i_error = 1; } else if(cz == 'T') { /* local string variable */ i_index = tfni_string_to_integer(&psg_pline[i_beg], 5); i_index = i_index + ig_svstack_ct; if(i_index >= 0 && i_index < VSTRINGS) { n_long = nga_strings_lg[i_index]; tsub_make_long_string(psp_1, n_long); tsub_copy(*psp_1, psga_strings[i_index], n_long); *pnp_long = n_long; } else i_error = 1; } else if(cz == 'U') { /* stored string literal */ i_index = tfni_string_to_integer(&psg_pline[i_beg], 5); if(i_index >= 0 && i_index < VSTRINGS) { n_long = nga_strings_lg[i_index]; tsub_make_long_string(psp_1, n_long); tsub_copy(*psp_1, psga_strings[i_index], n_long); *pnp_long = n_long; } else i_error = 1; } else if(cz == 'D') { /* global decimal variable */ i_index = tfni_string_to_integer(&psg_pline[i_beg], 5); if(i_index >= 0 && i_index < VDECIMALS) { dg_1pass = dga_decimals[i_index]; tsub_double_to_string(); n_long = ng_pass_lg; tsub_make_long_string(psp_1, n_long); tsub_copy(*psp_1, sg_pass, n_long); *pnp_long = n_long; } else i_error = 1; } else if(cz == 'E') { /* local decimal variable */ i_index = tfni_string_to_integer(&psg_pline[i_beg], 5); i_index = i_index + ig_dvstack_ct; if(i_index >= 0 && i_index < VDECIMALS) { dg_1pass = dga_decimals[i_index]; tsub_double_to_string(); n_long = ng_pass_lg; tsub_make_long_string(psp_1, n_long); tsub_copy(*psp_1, sg_pass, n_long); *pnp_long = n_long; } else i_error = 1; } else if(cz == 'F') { /* stored decimal literal */ i_index = tfni_string_to_integer(&psg_pline[i_beg], 5); if(i_index >= 0 && i_index < VDECIMALS) { dg_1pass = dga_decimals[i_index]; tsub_double_to_string(); n_long = ng_pass_lg; tsub_make_long_string(psp_1, n_long); tsub_copy(*psp_1, sg_pass, n_long); *pnp_long = n_long; } else i_error = 1; } else if(cz == 'C') { /* single character literal */ i_index = tfni_string_to_integer(&psg_pline[i_beg], 5); if(i_index >= 0 && i_index < 256) { tsub_make_long_string(psp_1, 5); *psp_1[0] = (char)i_index; *pnp_long = 1; } else i_error = 1; } else if(cz == 'N') { /* positive numeric literal */ i_index = tfni_string_to_integer(&psg_pline[i_beg], 5); dg_1pass = i_index; tsub_double_to_string(); n_long = ng_pass_lg; tsub_make_long_string(psp_1, n_long); tsub_copy(*psp_1, sg_pass, n_long); *pnp_long = n_long; } else if(cz == 'M') { /* negative numeric literal */ i_index = tfni_string_to_integer(&psg_pline[i_beg], 5); dg_1pass = -i_index; tsub_double_to_string(); n_long = ng_pass_lg; tsub_make_long_string(psp_1, n_long); tsub_copy(*psp_1, sg_pass, n_long); *pnp_long = n_long; } else i_error = 1; if(i_error == 1) sub_program_error_end("fetch str3 bad", 14); } /* sub_fetch_string3 */ void sub_store_string3(char *sp_var, char *sp_string, long np_long) { /* updated 2005/06/24, 2005/04/15, 2005/04/14 */ /* 2005/03/12, 2005/02/18, 2005/02/17, 2005/02/01, 2004/11/20 */ /* 012345 */ /* S12345 */ int i_index; int i_error = 2; int i_number; /* the string is in psp_string,np_long */ if(np_long > MAXSTRING) { i_error = 1; np_long = MAXSTRING; } /* S is a global string, T is a local string */ /* use psp_string, np_long */ /* char 48 is zero */ i_number = tfni_string_to_integer(&sp_var[1], 5); if(sp_var[0] == 'S') i_index = i_number; else if(sp_var[0] == 'T') i_index = i_number + ig_svstack_ct; else i_error = 1; if(i_index >= 0 && i_index < VSTRINGS) { /* input here is psg_use1, ng_use1 */ tsub_make_long_string(&psga_strings[i_index], np_long); tsub_copy(psga_strings[i_index], sp_string, np_long); nga_strings_lg[i_index] = np_long; } else i_error = 1; if(i_error == 1) sub_program_error_end("bad use str store", 17); } /* sub_store_string3 */ void sub_store_string_in_link(char *sp_string, long np_long) { /* updated 2008/01/08, 2005/06/24, 2005/04/15, 2005/04/14 */ /* 2005/03/12, 2005/02/18, 2005/02/17, 2005/02/01, 2004/11/20 */ /* 012345 */ /* S12345 */ int i_index; int i_error = 2; /* the string is in psp_string,np_long */ if(np_long > MAXSTRING) { i_error = 1; np_long = MAXSTRING; } /* S is a global string, T is a local string */ if(psg_pline[5] == 'S') i_index = ig_link_ix; else if(psg_pline[5] == 'T') i_index = ig_link_ix + ig_svstack_ct; else i_error = 1; if(i_index >= 0 && i_index < VSTRINGS) { /* input here is sp_string, np_long */ tsub_make_long_string(&psga_strings[i_index], np_long); tsub_copy(psga_strings[i_index], sp_string, np_long); nga_strings_lg[i_index] = np_long; } else i_error = 1; if(i_error == 1) sub_program_error_end("bad use str store", 17); } /* sub_store_string_in_link */ /* fetch and store subroutines above */ /* program prepare subroutines below */ void sub_prep_no_spaces(void) { /* updated 2005/12/05, 2005/09/03, 2004/12/17 */ /* remove spaces and add comma in 4 and ; at end */ int iy, iz; char s_pline[200]; if(sg_pline[4] == ' ') sg_pline[4] = ','; /* program line is in sg_pline with length ig_pline_lg */ /* put semi-colon on end */ sg_pline[ig_pline_lg] = ';'; ig_pline_lg++; /* sg_pline and s_pline are 200 long */ /* iz in index for sg_pline, iy is index for s_pline */ for(iy = 0, iz = 0; iz < ig_pline_lg; iz++) { /* to copy from sg_pline to s_pline or not */ if(sg_pline[iz] != ' ') { s_pline[iy] = sg_pline[iz]; iy++; } } /* put back into sg_pline,100 */ tsub_copy(sg_pline, s_pline, iy); ig_pline_lg = iy; } /* sub_prep_no_spaces */ void sub_prep_split(int *ip_colon) { /* updated 2005/03/01 */ /* find out of quotes colon */ int i_inquotes, i_colon, iz; char c_quote, cz; /* program line is in sg_pline with length ig_pline_lg */ i_colon = -1; c_quote = '"'; i_inquotes = 2; for(iz = 0; iz < ig_pline_lg; iz++) { cz = sg_pline[iz]; /* set i_inquotes = 1 if in quoted else 2 */ if(i_inquotes == 2) { if(cz == ':') i_colon = iz; if(cz == '"' || cz == '#') { i_inquotes = 1; c_quote = cz; } } else if(cz == c_quote) i_inquotes = 2; } *ip_colon = i_colon; } /* sub_prep_split */ void sub_prep_literal_strings(void) { /* updated 2005/12/03, 2005/12/01 */ /* 2005/11/30, 2005/09/03, 2005/04/19, 2005/03/31, 2005/03/16 */ /* replace literal strings in sg_pline,ig_pline_lg */ int i_byte, i_char, i_long, i_index, i_beg, i_end, iz; char sz[10]; tsub_copy(sg_pass, sg_pline, ig_pline_lg); ng_pass_lg = ig_pline_lg; /* ig_smaxglobal_ct is the max of string global variables */ /* ig_smaxliteral_ct is the count of stored literal strings */ for(i_byte = 0; i_byte < ng_pass_lg; i_byte++) { if(sg_pass[i_byte] == '"' || sg_pass[i_byte] == '#') { i_beg = i_byte + 1; i_end = 0; for(iz = i_beg; iz < ng_pass_lg; iz++) { if(sg_pass[iz] == sg_pass[i_byte]) { i_end = iz; i_long = i_end - i_beg; iz = ng_pass_lg; } } if(i_end > i_beg && i_long == 1) { /* one byte string */ /* replace "A" with C00065 */ i_char = sg_pass[i_byte + 1]; sprintf(sz, "C%05d", i_char); tsub_pass_insert(i_byte, "000", 3); tsub_copy(&sg_pass[i_byte], sz, 6); i_end = 0; } if(i_end >= i_beg) { /* we have a string to store */ ig_smaxliteral_ct++; i_index = ig_smaxglobal_ct + ig_smaxliteral_ct; if(i_index > VSTRINGS) { sub_program_error_end("too many strings", 16); i_end = 0; } } if(i_end >= i_beg) { /* store the string at i_index */ tsub_make_long_string(&psga_strings[i_index], i_long); tsub_copy(psga_strings[i_index], &sg_pass[i_beg], i_long); nga_strings_lg[i_index] = i_long; /* replace the string with U00000 */ tsub_pass_delete(i_byte, i_long + 2); sprintf(sz, "U%05d", i_index); tsub_pass_insert(i_byte, sz, 6); } } } tsub_copy(sg_pline, sg_pass, ng_pass_lg); ig_pline_lg = ng_pass_lg; } /* sub_prep_literal_strings */ void sub_prep_variables_str(char *ps_vars, int *pi_vars_lg) { /* updated 2005/10/29, 2005/09/03 */ /* 2005/02/07, 2005/02/06, 2005/02/05, 2005/01/30, 2004/12/18 */ /* prep variables for string variables */ /* program line is in sg_pline,ig_pline_lg */ int i_long, i_byte, ix, iy, iz; int i_inquotes, i_vari_pline, i_vars_lg; int i_typevar; int i_action; char s_var[65]; char c_quote, c_z; int i_var_string; char s_var_string[10]; /* ps_vars has the variable names in it csv */ /* pi_vars_lg and i_vars_lg have the length of ps_vars */ /* put value of *pi_vars_lg into i_vars_lg */ i_vars_lg = *pi_vars_lg; /* program line is in sg_pline,ig_pline_lg */ i_action = 1; /* do we have an ENDS line */ if(tfni_compare_strings(sg_pline, "ENDS", 4) == 0) i_action = 200; /* do we have a VARI line to define variables */ if(tfni_compare_strings(sg_pline, "VARI", 4) == 0) i_vari_pline = 1; else i_vari_pline = 2; c_quote = '"'; i_inquotes = 2; i_byte = 5; if(i_action > 20) i_byte = 1000; for(; i_byte < ig_pline_lg; i_byte++) { if(i_inquotes == 1) { /* leaving inquotes */ if(sg_pline[i_byte] == c_quote) i_inquotes = 2; } else if(sg_pline[i_byte] == '"' || sg_pline[i_byte] == '#') { /* entering inquotes */ i_inquotes = 1; c_quote = sg_pline[i_byte]; } if(i_inquotes != 1) { /* we are not inquotes */ /* do we have either a global or local decimal */ i_typevar = 0; if(tfni_compare_strings(&sg_pline[i_byte], "SG_", 3) == 0) { i_typevar = 1; } else if(tfni_compare_strings(&sg_pline[i_byte], "S_", 2) == 0) { i_typevar = 2; } if(i_typevar > 0) { /* find end of variable */ if(i_typevar == 1) iy = i_byte + 3; else iy = i_byte + 2; for(ix = 1; ix == 1; iy++) { /* must be letters or numbers */ c_z = sg_pline[iy]; ix = 2; if(c_z >= 'A' && c_z <= 'Z') ix = 1; else if(c_z >= '0' && c_z <= '9') ix = 1; } /* get new variable into s_var,i_long */ i_long = iy - i_byte - 1; if(i_long > 64) i_long = 64; tsub_copy(s_var, &sg_pline[i_byte], i_long); /* variable in s_var begins at i_byte for i_long */ if(i_vari_pline == 1) { /* vari line */ /* globals begin with a colon, locals with a comma */ if(i_typevar == 1) ps_vars[i_vars_lg] = ':'; else ps_vars[i_vars_lg] = ','; i_vars_lg++; /* variable is in s_var,i_long */ /* do we have variable overlap in ps_vars,i_vars_lg */ sub_program_variable_overlap(s_var, i_long, ps_vars, i_vars_lg); /* add new variable to ps_vars,pi_vars_lg csv */ tsub_copy(&ps_vars[i_vars_lg], s_var, i_long); i_vars_lg = i_vars_lg + i_long; } else { /* non vari line */ /* is this variable in ps_vars,pi_vars_lg */ ix = tfnn_string_lookup(ps_vars, i_vars_lg, s_var, i_long); /* is the end really the end in ps_var */ c_z = ps_vars[ix + i_long]; if(c_z != ':' && c_z != ',' && c_z != ' ') ix = -1; if(ix >= 0) { /* we have this variable */ if(i_typevar == 1) { /* global variable */ /* how many colons to determine i_var_string */ i_var_string = 0; for(iz = 0; iz < ix; iz++) { if(ps_vars[iz] == ':') i_var_string++; } /* global make S12345 string of i_var_string */ sprintf(s_var_string, "S%05d", i_var_string); } else { /* local variable */ /* how many commas to determine i_var_string */ i_var_string = 0; for(iz = 0; iz < ix; iz++) { if(ps_vars[iz] == ',') i_var_string++; } /* local make T12345 string of i_var_string */ sprintf(s_var_string, "T%05d", i_var_string); } /* replace s_var in sg_pline,ig_pline_lg with */ tsub_copy(sg_pass, sg_pline, ig_pline_lg); ng_pass_lg = ig_pline_lg; tsub_pass_delete(i_byte, i_long); tsub_pass_insert(i_byte, s_var_string, 6); tsub_copy(sg_pline, sg_pass, ng_pass_lg); ig_pline_lg = ng_pass_lg; } } } } } if(i_action == 200) { /* we have an ENDS line and must blank local variables */ /* find first comma and blank from there on */ iy = -1; for(iz = 0; iz < i_vars_lg && iy == -1; iz++) { if(ps_vars[iz] == ',') iy = iz; } if(iy > -1) { for(iz = iy; iz < VCHARNAME; iz++) ps_vars[iz] = ' '; i_vars_lg = iy; } } /* put i_vars_lg into *pi_vars_lg */ *pi_vars_lg = i_vars_lg; } /* sub_prep_variables_str */ void sub_prep_variables_dec(char *ps_vars, int *pi_vars_lg) { /* updated 2005/10/29, 2005/09/03 */ /* 2005/03/12, 2005/02/06, 2005/02/05, 2005/01/30, 2004/12/18 */ /* prep variables for decimal variables */ /* program line is in sg_pline,ig_pline_lg */ int i_long, i_byte, ix, iy, iz; int i_inquotes, i_vari_pline, i_vars_lg; int i_typevar; int i_action; char s_var[65]; char c_quote, c_z; int i_var_decimal; char s_var_decimal[10]; /* ps_vars has the variable names in it csv */ /* pi_vars_lg and i_vars_lg have the length of ps_vars */ /* put value of *pi_vars_lg into i_vars_lg */ i_vars_lg = *pi_vars_lg; /* program line is in sg_pline,ig_pline_lg */ i_action = 1; /* do we have an ENDS line */ if(tfni_compare_strings(sg_pline, "ENDS", 4) == 0) i_action = 200; /* do we have a VARI line to define variables */ if(tfni_compare_strings(sg_pline, "VARI", 4) == 0) i_vari_pline = 1; else i_vari_pline = 2; c_quote = '"'; i_inquotes = 2; i_byte = 5; if(i_action > 20) i_byte = 1000; for(; i_byte < ig_pline_lg; i_byte++) { if(i_inquotes == 1) { /* leaving inquotes */ if(sg_pline[i_byte] == c_quote) i_inquotes = 2; } else if(sg_pline[i_byte] == '"' || sg_pline[i_byte] == '#') { /* entering inquotes */ i_inquotes = 1; c_quote = sg_pline[i_byte]; } if(i_inquotes != 1) { /* we are not inquotes */ /* do we have either a global or local decimal */ i_typevar = 0; if(tfni_compare_strings(&sg_pline[i_byte], "DG_", 3) == 0) { i_typevar = 1; } else if(tfni_compare_strings(&sg_pline[i_byte], "D_", 2) == 0) { i_typevar = 2; } if(i_typevar > 0) { /* find end of variable */ if(i_typevar == 1) iy = i_byte + 3; else iy = i_byte + 2; for(ix = 1; ix == 1; iy++) { /* must be letters or numbers */ c_z = sg_pline[iy]; ix = 2; if(c_z >= 'A' && c_z <= 'Z') ix = 1; else if(c_z >= '0' && c_z <= '9') ix = 1; } /* get new variable into s_var,i_long */ i_long = iy - i_byte - 1; if(i_long > 64) i_long = 64; tsub_copy(s_var, &sg_pline[i_byte], i_long); /* variable begins in s_var at i_byte for i_long */ if(i_vari_pline == 1) { /* vari line */ /* globals begin with a colon, locals with a comma */ if(i_typevar == 1) ps_vars[i_vars_lg] = ':'; else ps_vars[i_vars_lg] = ','; i_vars_lg++; /* variable is in s_var,i_long */ /* do we have variable overlap in ps_vars,i_vars_lg */ sub_program_variable_overlap(s_var, i_long, ps_vars, i_vars_lg); /* add new variable to ps_vars,pi_vars_lg csv */ tsub_copy(&ps_vars[i_vars_lg], s_var, i_long); i_vars_lg = i_vars_lg + i_long; } else { /* non vari line */ /* is this variable in ps_vars,pi_vars_lg */ ix = tfnn_string_lookup(ps_vars, i_vars_lg, s_var, i_long); /* is the end really the end in ps_vars */ c_z = ps_vars[ix + i_long]; if(c_z != ':' && c_z != ',' && c_z != ' ') ix = -1; if(ix >= 0) { /* we have this variable */ if(i_typevar == 1) { /* global variable */ /* how many colons to determine i_var_decimal */ i_var_decimal = 0; for(iz = 0; iz < ix; iz++) { if(ps_vars[iz] == ':') i_var_decimal++; } /* global make D12345 string of i_var_decimal */ sprintf(s_var_decimal, "D%05d", i_var_decimal); } else { /* local variable */ /* how many commas to determine i_var_decimal */ i_var_decimal = 0; for(iz = 0; iz < ix; iz++) { if(ps_vars[iz] == ',') i_var_decimal++; } /* local make E12345 string of i_var_decimal */ sprintf(s_var_decimal, "E%05d", i_var_decimal); } /* replace s_var in sg_pline,ig_pline_lg with */ tsub_copy(sg_pass, sg_pline, ig_pline_lg); ng_pass_lg = ig_pline_lg; tsub_pass_delete(i_byte, i_long); tsub_pass_insert(i_byte, s_var_decimal, 6); tsub_copy(sg_pline, sg_pass, ng_pass_lg); ig_pline_lg = ng_pass_lg; } } } } } if(i_action == 200) { /* we have an ENDS line and must blank local variables */ /* find first comma and blank from there on */ iy = -1; for(iz = 0; iz < i_vars_lg && iy == -1; iz++) { if(ps_vars[iz] == ',') iy = iz; } if(iy > -1) { for(iz = iy; iz < VCHARNAME; iz++) ps_vars[iz] = ' '; i_vars_lg = iy; } } /* put i_vars_lg into *pi_vars_lg */ *pi_vars_lg = i_vars_lg; } /* sub_prep_variables_dec */ void sub_program_variable_overlap(char *sp1, int ip1, char *sp2, int ip2) { /* updated 2005/10/29 */ /* compare var in sp1 against : or , delimited variables in sp2 */ int i_byte, iy, iz; int i_error = 2; /* 1 is a find, 2 is a no find */ for(iy = 1, i_byte = 0; iy == 1 && i_byte < ip2; i_byte++) { if(sp1[0] == sp2[i_byte] && sp1[1] == sp2[i_byte + 1] && sp1[2] == sp2[i_byte + 2] && sp1[3] == sp2[i_byte + 3]) { for(iz = 4; iz < ip1; iz++) { if(sp1[iz] != sp2[i_byte + iz]) { if(sp2[i_byte + iz] == ',' || sp2[i_byte + iz] == ':') { i_error = 1; iy = i_byte; } else iz = 1000; } else if(iz == (ip1 - 1)) { i_error = 1; iy = i_byte; } } } } if(i_error == 1) { /* line is not in program array yet */ tsub_out79(sp1, ip1); tsub_out79(&sp2[iy], 12); tsub_show_pline(ig_pline_ix, sg_pline, ig_pline_lg); tsub_out79("var overlap", 11); tsub_inp79(); ig_exit = 1; } } /* sub_program_variable_overlap */ void sub_prep_evar(int pi_type, char *ps_pline, char *ps_vars, int pi_vars_lg) { /* updated 2005/09/03, 2005/03/12, 2005/02/06 */ /* we have an EVAR line, how many colons */ /* pi_type=1 means local, pi_type=2 means global */ /* 012345678901234567 */ /* EVAR N12345,N12345 */ int iy, iz; char s_count[10]; if(pi_type == 1) { /* local */ iy = 0; for(iz = 0; iz < pi_vars_lg; iz++) if(ps_vars[iz] == ',') iy++; } else { /* global */ iy = 0; for(iz = 0; iz < pi_vars_lg; iz++) if(ps_vars[iz] == ':') iy++; } sprintf(s_count, "%05d", iy); if(ps_vars[1] == 'D') tsub_copy(&ps_pline[6], s_count, 5); else tsub_copy(&ps_pline[13], s_count, 5); } /* sub_prep_evar */ void sub_prep_format1(void) { /* updated 2005/09/03, 2005/02/13 */ /* prep the format of sg_pline,ig_pline_lg */ /* put in DSET,$SET,ESUB if needed */ int iz; /* copy to sg_pass,ng_pass_lg */ tsub_copy(sg_pass, sg_pline, ig_pline_lg); ng_pass_lg = ig_pline_lg; /* insert DSET, if needed */ iz = tfni_compare_strings(sg_pass, "DG_", 3); if(iz != 0) iz = tfni_compare_strings(sg_pass, "D_", 2); if(iz == 0) tsub_pass_insert(0, "DSET,", 5); /* insert $SET, if needed */ iz = tfni_compare_strings(sg_pass, "SG_", 3); if(iz != 0) iz = tfni_compare_strings(sg_pass, "S_", 2); if(iz == 0) tsub_pass_insert(0, "$SET,", 5); /* insert ESUB, if needed */ iz = tfni_compare_strings(sg_pass, "SUB_", 4); if(iz == 0) tsub_pass_insert(0, "ESUB,", 5); /* copy sg_pass,ng_pass_lg to sg_pline,ig_pline_lg */ tsub_copy(sg_pline, sg_pass, ng_pass_lg); ig_pline_lg = ng_pass_lg; } /* sub_prep_format1 */ void sub_prep_format2(void) { /* updated 2011/06/03 */ /* 2005/09/03, 2005/03/12, 2005/03/01, 2005/02/27, 2005/02/13 */ /* prep the format of sg_pline,ig_pline_lg */ /* put + in DSET and make compare two bytes in DIFT,$IFT */ int iz; char cz; /* copy to sg_pass,ng_pass_lg */ tsub_copy(sg_pass, sg_pline, ig_pline_lg); ng_pass_lg = ig_pline_lg; /* insert a + in a DSET, command */ if(tfni_compare_strings(sg_pass, "DSET,", 5) == 0) { /* do we need a plus sign after the = */ /* 012345678901234567 */ /* DSET,D00001=N00001 */ if(sg_pass[12] != '+' && sg_pass[12] != '-') tsub_pass_insert(12, "+", 1); } /* make the compare two bytes in DWHI,$WHI,DIFT,$IFT */ iz = tfni_compare_strings(sg_pass, "DIFT,", 5); if(iz != 0) iz =tfni_compare_strings(sg_pass, "DIF1,", 5); if(iz != 0) iz =tfni_compare_strings(sg_pass, "DWHI,", 5); if(iz != 0) iz =tfni_compare_strings(sg_pass, "DBAD,", 5); if(iz != 0) iz =tfni_compare_strings(sg_pass, "$IFT,", 5); if(iz != 0) iz =tfni_compare_strings(sg_pass, "$IF1,", 5); if(iz != 0) iz =tfni_compare_strings(sg_pass, "$WHI,", 5); if(iz == 0) { /* do we need a second byte to the compare */ /* 012345678901234567 */ /* DIFT,D12345=N12345 */ /* ==,>=,<=,<>,<<,>> */ cz = sg_pass[12]; if(cz != '=' && cz != '<' && cz != '>') { cz = sg_pass[11]; if(cz == '=' || cz == '<' || cz == '>') { tsub_pass_insert(12, " ", 1); sg_pass[12] = cz; } } } /* copy sg_pass,ng_pass_lg to sg_pline,ig_pline_lg */ tsub_copy(sg_pline, sg_pass, ng_pass_lg); ig_pline_lg = ng_pass_lg; } /* sub_prep_format2 */ void sub_prep_literal_numbers(void) { /* updated 2005/12/03, 2005/09/03, 2005/03/13, 2005/03/12, 2005/02/12 */ /* prep or store literal numbers in sg_pline,ig_pline_lg */ /* change 1 to N0001 */ int i_action, i_byte, i_long, i_decimal; int i_prev, i_pprev, iz; int i_index = 0; char c_prev, c_pprev, c_byte, c_char; char sz[10]; double d_number; /* copy sg_pline,ig_pline_lg to sg_pass,ng_pass_lg */ tsub_copy(sg_pass, sg_pline, ig_pline_lg); ng_pass_lg = ig_pline_lg; for(i_byte = 0; i_byte < ng_pass_lg; i_byte++) { i_action = 1; if(i_action == 1) { /* not inquotes */ i_prev = i_byte - 1; i_pprev = i_byte - 2; c_prev = sg_pass[i_prev]; c_pprev = sg_pass[i_pprev]; c_byte = sg_pass[i_byte]; /* prev cannot be a number, letter, underline or decimal */ if(c_prev >= '0' && c_prev <= '9') i_action = 0; if(c_prev >= 'A' && c_prev <= 'Z') i_action = 0; if(c_prev == '_') i_action = 0; if(c_prev == '.') i_action = 0; /* current i_byte must be a number */ if(c_byte < '0' || c_byte > '9') i_action = 0; } if(i_action == 1) { /* how long is the number and is there a decimal */ d_number = 0; i_decimal = -5; i_long = 0; for(iz = i_byte; iz < ng_pass_lg; iz++) { c_char = sg_pass[iz]; if(c_char >= '0' && c_char <= '9') { d_number = d_number * 10 + c_char - 48; if(i_decimal != -5) i_decimal++; i_long++; } else if(c_char == '.') { if(i_decimal != -5) i_action = 0; i_long++; i_decimal = 0; } else iz = ng_pass_lg; } for(iz = 0; iz < i_decimal; iz++) d_number = d_number / 10; if(i_long <= 5 && i_decimal == -5) i_action = 2; if(i_long > 5 || i_decimal != -5) i_action = 3; } if(i_action == 2) { /* reformat the number to N12345 */ /* insert into sg_pass */ tsub_pass_insert(i_byte, "N00000", 6 - i_long); /* should it be M instead of N to mean negative */ if(c_prev == '-' || c_prev == '+') { /* there must be some operator just previous */ iz = tfnn_string_char_search(",=<>+-*/\%", 10, c_pprev); if(iz >= 0) { tsub_pass_delete(i_prev, 1); i_byte--; if(c_prev== '-') sg_pass[i_byte] = 'M'; } } } if(i_action == 3) { /* we have a decimal number to store */ ig_dmaxliteral_ct++; i_index = ig_dmaxglobal_ct + ig_dmaxliteral_ct; if(i_index > VDECIMALS) { sub_program_error_end("too many numbers", 16); i_action = 9; } } if(i_action == 3) { /* is our decimal number negative */ if(c_prev == '-' || c_prev == '+') { /* there must be some operator just previous */ iz = tfnn_string_char_search(",=<>+-*/\%", 10, c_pprev); if(iz >= 0) { tsub_pass_delete(i_prev, 1); i_byte--; if(c_prev== '-') d_number = -d_number; } } /* store the decimal number at i_index */ dga_decimals[i_index] = d_number; /* replace the string with F00000 */ tsub_pass_delete(i_byte, i_long); sprintf(sz, "F%05d", i_index); tsub_pass_insert(i_byte, sz, 6); } } /* put the pline back into sg_pline,ig_pline_lg */ tsub_copy(sg_pline, sg_pass, ng_pass_lg); ig_pline_lg = ng_pass_lg; } /* sub_prep_literal_numbers */ /* program prepare subroutines above */ /* utility subroutines below */ int tfni_char_type(char cp_1) { /* updated 2009/11/01, 2005/03/25 */ /* long */ int i_type; /* Case pi_char of 0 .. 31 : i_result := 1; 32 : i_result := 2; 33 .. 47 : i_result := 3; 48 .. 57 : i_result := 4; 58 .. 64 : i_result := 3; 65 .. 90 : i_result := 5; 91 .. 96 : i_result := 3; 97 .. 122 : i_result := 6; 123 .. 126 : i_result := 3; else i_result := 7; end; */ if(cp_1 <= 31) i_type = 1; /* escape characters */ else if(cp_1 == 32) i_type = 2; /* the space */ else if(cp_1 <= 47) i_type = 3; /* punctuation etc */ else if(cp_1 <= 57) i_type = 4; /* numbers */ else if(cp_1 <= 64) i_type = 3; /* punctuation etc */ else if(cp_1 <= 90) i_type = 5; /* upper case */ else if(cp_1 <= 96) i_type = 3; /* punctuation etc */ else if(cp_1 <= 122) i_type = 6; /* lower case */ else if(cp_1 <= 126) i_type = 3; /* punctuation etc */ else i_type = 7; /* greater than 126 */ return i_type; } /* tfni_char_type */ int tfni_is_digits(char *sp1, int ip_long) { /* updated 2005/08/06 */ int i_result = 1; int iz; for(iz = 0; i_result == 1 && iz < ip_long; iz++) { if(sp1[iz] < '0' || sp1[iz] > '9') i_result++; } return i_result; } /* tfni_is_digits */ int tfni_compare_strings(char *sp1, char *sp2, long np_long) { /* updated 2005/07/24, 2005/05/10, 2004/11/13 */ /* long */ /* compare strings sp1>sp2=1,sp1 sp2[nz]) i_result = 1; } return i_result; } /* tfni_compare_strings */ long tfnn_string_lookup(char *sp1, long np1, char *sp2, long np2) { /* updated 2004/12/13 */ /* long */ /* look up sp2 for length ip2 in sp1 for length ip1 */ int i_loop, i_test; long n_return, nx, nz; n_return = -1; nz = 0; i_loop = 1; if(np2 > np1) i_loop++; if(np1 == 0 || np2 == 0) i_loop++; while(i_loop == 1) { if(sp1[nz] == sp2[0]) { for(i_test = 1, nx = 1; i_test == 1 && nx < np2; nx++) if(sp1[nz + nx] != sp2[nx]) i_test++; if(i_test == 1) n_return = nz; } nz++; if(nz > (np1 - np2)) i_loop++; } return n_return; } /* tfnn_string_lookup */ long tfnn_string_char_search(char *sp1, long np_long, char cp1) { /* updated 2005/05/10, 2005/03/13, 2004/12/13 */ /* long */ long ny, nz; for(ny = -1, nz = 0; ny == -1 && nz < np_long; nz++) { if(sp1[nz] == cp1) ny = nz; } return ny; } /* tfni_string_char_search */ int tfni_string_to_integer(char *sp1, int ip_long) { /* updated 2005/02/17, 2004/11/14 */ /* long */ int iy, iz; int i_integer = 0; int i_error = 2; for(iz = 0; iz < ip_long; iz++) { /* 0 is 48, 9 is 57 */ iy = sp1[iz] - 48; if(iy >= 0 && iy <= 9) i_integer = i_integer * 10 + iy; else i_error = 1; } if(i_error == 1) { tsub_out79(sp1, ip_long); sub_program_error_end("bad variable int", 16); i_integer = 0; } return i_integer; } /* tfni_string_to_integer */ long tfnn_hash(char *sp1, int ip_long) { /* updated 2007/04/10, 2005/02/08 */ /* to change a string into a fairly unique number */ /* the string is a subr identifier or a tag identifier */ int iz; long n_hash = 0; long n_value, n_char; for(iz = 0; iz < ip_long; iz++) { /* 48 to 57 is 0 thru 9 */ /* 65 to 90 is A thru Z, _ is 95 */ n_char = sp1[iz]; n_value = 0; if(n_char >= 48 && n_char <= 95) n_value = n_char * n_char * n_char; n_hash = n_hash * 2 + n_value; /* one billion */ if(n_hash > 1000000000) n_hash = n_hash - 1000000000; } return n_hash; } /* tfnn_hash */ void tsub_string_to_double(char *sp1, int ip_long) { /* updated 2005/02/19, 2004/11/30 */ /* long */ double d_double = 0; int i_good = 1; int i_commas = 0; int i_decimal = -1; int i_negative = 2; int i_numbers = 0; int i_beg, i_end, iz; /* trim right blanks */ for(i_end = ip_long - 1; i_end > 0 && sp1[i_end] == ' '; i_end--); ip_long = i_end + 1; /* trim left blanks */ for(i_beg = 0; i_beg < ip_long && sp1[i_beg] == ' '; i_beg++); if(ip_long < 1) i_good++; iz = i_beg; if(i_good == 1) { if(sp1[0] == '-') { i_negative = 1; iz = 1; } else if(sp1[0] == '+') iz = 1; if(iz >= ip_long) i_good++; } if(i_good == 1) { for(; iz < ip_long; iz++) { if(sp1[iz] >= '0' && sp1[iz] <= '9') { /* we do have a number */ i_numbers++; /* zero is 48 */ d_double = d_double * 10 + sp1[iz] - 48; if(i_decimal >= 0) i_decimal++; } else { /* we do not have a number */ if(sp1[iz] == '.') i_decimal = 0; else if(sp1[iz] == ',') i_commas++; else i_good++; } } if(i_commas > 6) i_good++; if(i_numbers == 0) i_good++; } if(i_good == 1) { /* put decimal in correctly */ for(iz = 0; iz < i_decimal; iz++) d_double = d_double / 10; if(i_negative == 1) d_double = - d_double; } ig_pass_int = i_good; dg_1pass = d_double; } /* tsub_string_to_double */ void tsub_timeline(void) { /* updated 2009/07/05 */ struct tm *ptr_tm; time_t t_time_t; char sz[80]; int iz; /* 01234567890123456789012345678901234 */ /* Sun Nov 28 19:10:06 2004 */ /* 20-NOV-2004 19:10:06 20041120191006 */ t_time_t = time(NULL); ptr_tm = localtime(&t_time_t); sprintf(sz, "%s", asctime(ptr_tm)); if(sz[8] == ' ') sz[8] = '0'; if(sz[11] == ' ') sz[11] = '0'; if(sz[14] == ' ') sz[14] = '0'; if(sz[17] == ' ') sz[17] = '0'; tsub_blank(sg_pass, 40); tsub_copy(sg_pass, &sz[8], 2); sg_pass[2] = '-'; tsub_copy(&sg_pass[3], &sz[4], 3); sg_pass[6] = '-'; tsub_copy(&sg_pass[7], &sz[20], 4); tsub_copy(&sg_pass[12], &sz[11], 8); tsub_case_upper(sg_pass, 20); tsub_copy(&sg_pass[21], &sz[20], 4); iz = ptr_tm->tm_mon + 1; sprintf(&sz[41], "%2d", iz); if(sz[41] == ' ') sz[41] = '0'; tsub_copy(&sg_pass[25], &sz[41], 2); tsub_copy(&sg_pass[27], &sz[8], 2); tsub_copy(&sg_pass[29], &sz[11], 2); tsub_copy(&sg_pass[31], &sz[14], 2); tsub_copy(&sg_pass[33], &sz[17], 2); ng_pass_lg = 35; /* string is in sg_pass,ng_pass_lg */ } /* void tsub_timeline(char *sp1, int ip_long) */ void tsub_blank(char *sp1, long np_long) { /* updated 2005/05/10, 2004/11/13 */ /* long */ long nz; for(nz = 0; nz < np_long; nz++) sp1[nz] = ' '; } /* tsub_blank */ void tsub_blank_escapes(char *sp1, long np_long) { /* updated 2005/05/10, 2004/11/13 */ /* long */ long nz; for(nz = 0; nz < np_long; nz++) if(sp1[nz] < 32) sp1[nz] = 32; } /* tsub_blank_escapes */ void tsub_bug(char *sp1) { /* updated 2005/05/11 */ char sz[20]; puts(sp1); fgets(sz, 10, stdin); } /* void tsub_bug */ void tsub_case_lower(char *sp1, long np_long) { /* updated 2005/05/10, 2004/11/14 */ /* long */ char cz; long nz; for(nz = 0; nz < np_long; nz++) { cz = sp1[nz]; if(cz >= 'A' && cz <= 'Z') sp1[nz] = (char)(cz + 32); } } /* tsub_case_lower */ void tsub_case_upper(char *sp1, long np_long) { /* updated 2005/05/10, 2005/02/21 */ /* long */ char cz; long nz; for(nz = 0; nz < np_long; nz++) { cz = sp1[nz]; if(cz >= 'a' && cz <= 'z') sp1[nz] = (char)(cz - 32); } } /* tsub_case_upper */ void tsub_copy(char *sp1, char *sp2, long np_long) { /* updated 2005/05/10, 2005/02/09, 2004/11/13 */ /* long */ /* copy from sp2 to sp1 for length np_long */ long nz; for(nz = 0; nz < np_long; nz++) sp1[nz] = sp2[nz]; } /* tsub_copy */ void sub_command_dbug(void) { /* updated 2010/06/18, 2010/06/04 */ /* 2009/07/10, 2008/01/29, 2005/11/27, 2005/11/23, 2004/11/21 */ int i_loop, iz; i_loop = 1; while(i_loop == 1) { /* dg_plines_done is how many lines were run */ /* dg_plines_done++; */ /* get the command number into i_command */ /* i_command = iga_link_commands[ig_pline_ix]; */ /* get the line sg_pline,ig_pline_lg from index ig_pline_ix */ ig_pline_lg = iga_plines_lg[ig_pline_ix]; /* tsub_copy(sg_pline, psga_plines[ig_pline_ix], ig_pline_lg); */ /* psg_pline = psga_plines[ig_pline_ix]; */ /* get the link for this line */ ig_link_ix = iga_links[ig_pline_ix]; /* show the current line */ tsub_show_pline_by_index(ig_pline_ix); /* show line index, length and link */ printf("ig_pline_ix=%d, ig_pline_lg=%d, ig_link_ix=%d, lines=%0.0f\n", ig_pline_ix, ig_pline_lg, ig_link_ix, dg_plines_done); /* show decimal and string stack counts */ printf("ig_dvstack_ct=%d, ig_svstack_ct=%d\n", ig_dvstack_ct, ig_svstack_ct); /* show decimal and string stack values */ printf("iga_dvstack[]=%d, iga_svstack[]=%d\n", iga_dvstack[ig_dvstack_ix], iga_svstack[ig_dvstack_ix]); /* get timeline into sg_pass,ng_pass_lg */ tsub_timeline(); tsub_out79(sg_pass, ng_pass_lg); i_loop++; puts("1=strings, 2=decimals"); puts("return, exit=exit prog"); /* get terminal input */ tsub_inp79(); tsub_blank_escapes(sg_inp79, 80); tsub_case_upper(sg_inp79, 80); if(tfni_compare_strings(sg_inp79, "EXIT", 4) == 0) { ig_exit = 1; } if(ng_inp79_long == 1) { i_loop = 1; for(iz = 0; iz < 10; iz++) { tsub_show_vstring_info(ng_inp79_long + iz); } } if(ng_inp79_long == 2) { i_loop = 1; for(iz = 0; iz < 10; iz++) { tsub_show_vdecimal_info(ig_dvstack_ct + iz); } } } } /* sub_command_dbug */ void tsub_double_to_string(void) { /* updated 2006/05/20 */ /* 2006/05/02, 2006/05/01, 2005/05/11, 2005/04/13, 2004/11/27 */ /* put dg_1pass into sg_pass, ng_pass_lg */ int iz; tsub_blank(sg_pass, 40); if(dg_1pass > pow(10, 16)) { /* if number greater than 10E16 */ ng_pass_lg = sprintf(sg_pass, "%.15E", dg_1pass); } else { /* default is six beyond decimal */ ng_pass_lg = sprintf(sg_pass, "%f", dg_1pass); /* eliminate trailing zeros */ for(iz = ng_pass_lg - 1; sg_pass[iz] == '0'; iz--); /* eliminate trailing decimal */ if(sg_pass[iz] == '.') iz--; ng_pass_lg = iz + 1; } } /* tsub_double_to_string */ void tsub_inp79(void) { /* updated 2005/03/13, 2005/02/23, 2004/12/11 */ /* long */ /* get screen input into sg_inp79,ig_inp79_lg,ng_inp79_long */ char sz[80], cz; int iy, iz; ng_inp79_long = 0; tsub_blank(sg_inp79, 79); fgets(sz, 79, stdin); for(iy = 0, iz = 0; iz < 79; iz++) { cz = sz[iz]; if(cz != 0) { sg_inp79[iz] = cz; iy = iz; if(cz >= '0' && cz <= '9') ng_inp79_long = ng_inp79_long * 10 + cz - 48; } else iz = 99; } ig_inp79_lg = iy; tsub_blank_escapes(sg_inp79, ig_inp79_lg); } /* tsub_inp79 */ void tsub_inp1024(void) { /* updated 2013/07/20, 2013/07/15, 2011/08/25 */ /* 2010/06/13, 2008/05/07, 2005/03/13, 2005/02/23, 2004/12/11 */ /* long */ /* get screen input into sg_inp1024,ig_inp1024_lg */ char sz[1026], cz; int iz; /* read upto 1024 bytes from the screen */ tsub_blank(sg_inp1024, 1024); fgets(sz, 1024, stdin); ig_inp1024_lg = 0; for(iz = 0; iz < 1024; iz++) { cz = sz[iz]; if(cz != 0) { sg_inp1024[iz] = cz; ig_inp1024_lg = iz; } else iz = 2000; } tsub_blank_escapes(sg_inp1024, ig_inp1024_lg); } /* tsub_inp1024 */ void tsub_line_of_char(char *sp1, char cp1, long np_long) { /* updated 2005/05/10, 2004/11/14 */ /* long */ long nz; for(nz = 0; nz < np_long; nz++) sp1[nz] = cp1; } /* tsub_line_of_char */ void tsub_out79(char *sp1, int ip_long) { /* updated 2004/12/18 */ /* long */ char sz[80]; if(ip_long > 79) ip_long = 79; tsub_blank(sz, 80); tsub_copy(sz, sp1, ip_long); tsub_blank_escapes(sz, 80); sz[79] = 0; puts(sz); } /* tsub_out79 */ void tsub_show_pline(int ip_index, char *sp1, int ip_long) { /* updated 2005/03/30, 2005/02/19, 2004/11/27 */ char sz[80]; tsub_blank(sz, 80); sprintf(sz, "%5d", ip_index); if(ip_long > 73) ip_long = 73; tsub_copy(&sz[6], sp1, ip_long); tsub_out79(sz, 79); } /* tsub_show_pline */ void tsub_show_pline_by_index(int ip_index) { /* updated 2007/10/11, 2005/04/01 */ char sz[80]; int i_long; if(ip_index > 0) { i_long = iga_plines_lg[ip_index]; tsub_blank(sz, 80); sprintf(sz, "%5d", ip_index); if(i_long > 73) i_long = 73; tsub_copy(&sz[6], psga_plines[ip_index], i_long); tsub_out79(sz, 79); } } /* tsub_show_pline */ void tsub_show_vstring_info(int ip_index) { /* updated 2007/10/15, 2005/05/11, 2005/04/14, 2004/11/27 */ int i_long; char s_string[80]; if(ip_index >= 0 && ip_index <= VSTRINGS) { i_long = nga_strings_lg[ip_index]; printf("string index=%d, length=%d\n", ip_index, i_long); if(i_long > 79) i_long = 79; tsub_copy(s_string, psga_strings[ip_index], i_long); tsub_out79(s_string, i_long); } } /* tsub_show_vstring_info */ void tsub_show_vdecimal_info(int ip_index) { /* updated 2007/10/15 */ double dz; if(ip_index >= 0 && ip_index <= VDECIMALS) { dz = dga_decimals[ip_index]; printf("index=%d decimal=%20.20f\n", ip_index, dz); } } /* tsub_show_vdecimal_info */ void tsub_make_long_string(char **psp1, long np_long) { /* updated 2011/05/03, 2007/01/08, 2006/10/17, 2005/09/11, 2005/08/17 */ /* 2005/07/21, 2005/07/19, 2005/07/03, 2005/05/11, 2005/05/09 */ /* **psp1 is a pointer to a string pointer */ /* MAXSTRING is the maximum string length */ /* tsub_make_long_string(&psg_1, ng_1, int ip_local); */ /* tsub_copy(psg_1, sz, 50); */ int i_error = 2; /* free does nothing to a pointer set to NULL */ free(*psp1); *psp1 = NULL; /* make the string one longer than needed for a 0 */ np_long = abs(np_long); np_long++; if(np_long < 2) { /* make a string of zero length */ /* the string can be a little longer */ *psp1 = (char *)malloc(5); if(*psp1 == NULL) i_error = 1; } else if(np_long <= MAXSTRING) { /* make a string of length np_long */ *psp1 = (char *)malloc(np_long); /* try again if it did not work */ if(*psp1 == NULL) *psp1 = (char *)malloc(np_long); if(*psp1 == NULL) i_error = 1; } else i_error = 1; if(i_error == 1) { printf("\nlength=%ld\n", np_long); sub_program_error_end("make_long_string", 16); } } /* tsub_make_long_string */ void tsub_use_append(char *psp_app, long np_app) { /* updated 2005/05/23, 2005/05/14, 2005/05/12, 2005/05/11 */ /* append psp_app,np_app to psg_use2,ng_use2 put in psg_use1,ng_use1 */ if(np_app < 0) np_app = 0; if(ng_use2 < 0) ng_use2 = 0; tsub_make_long_string(&psg_use1, ng_use2 + np_app); if(ig_exit != 1) { tsub_copy(psg_use1, psg_use2, ng_use2); tsub_copy(&psg_use1[ng_use2], psp_app, np_app); ng_use1 = ng_use2 + np_app; } } /* tsub_use_append */ void tsub_use_insert321(long np_beg) { /* updated 2005/07/17, 2005/05/22, 2005/05/19, 2005/05/16 */ /* insert string psg_use3,ng_use3 into psg_use2,ng_use2 at np_beg */ /* to make psg_use1,ng_use1 */ if(np_beg < 0) np_beg = 0; if(np_beg > ng_use2) np_beg = ng_use2; /* get a total final length */ ng_use1 = ng_use2 + ng_use3; /* create string psg_use1,ng_use1 */ tsub_make_long_string(&psg_use1, ng_use1); if(ig_exit != 1) { tsub_copy(psg_use1, psg_use2, np_beg); /* put in from psg_use3 into psg_use1 */ tsub_copy(&psg_use1[np_beg], psg_use3, ng_use3); /* put the ending from psg_use2,ng_use2 into psg_use1,ng_use1 */ tsub_copy(&psg_use1[np_beg + ng_use3], &psg_use2[np_beg], ng_use2 - np_beg); } } /* tsub_use_insert321 */ void tsub_use_move12(void) { /* updated 2005/06/05 */ /* move string psg_use1,ng_use1 to psg_use2,ng_use2 */ free(psg_use2); psg_use2 = psg_use1; ng_use2 = ng_use1; psg_use1 = NULL; ng_use1 = 0; } /* tsub_use_move12 */ void tsub_use_move21(void) { /* updated 2005/06/05 */ /* move string psg_use2,ng_use2 to psg_use1,ng_use1 */ free(psg_use1); psg_use1 = psg_use2; ng_use1 = ng_use2; psg_use2 = NULL; ng_use2 = 0; } /* tsub_use_move21 */ void tsub_use_replace(long np_beg, char *psp_rep, long np_rep) { /* updated 2005/06/05, 2005/05/22, 2005/05/19, 2005/05/17 */ /* in psg_use1,ng_use1 replace with psp_rep,np_rep beginning at np_beg */ long ny, nz; if(np_beg < 0) np_beg = 0; if(np_beg < ng_use1) { ny = np_beg; for(nz = 0; nz < np_rep && ny < ng_use1; nz++, ny++) { psg_use1[ny] = psp_rep[nz]; } } } /* tsub_use_replace */ void tsub_use_trim_left(char *psp_str, long np_long) { /* updated 2005/08/23, 2005/05/22, 2005/05/14 */ /* left trim psp_str,np_long into psg_use1,ng_use1 */ /* 0123456789 */ /* AAAA */ long n_long, nz; for(nz = 0; psp_str[nz] <= 32 && nz < np_long; nz++); n_long = np_long - nz; tsub_make_long_string(&psg_use1, n_long); if(ig_exit != 1) { tsub_copy(psg_use1, &psp_str[nz], n_long); ng_use1 = n_long; } } /* tsub_use_trim_left */ void tsub_use_trim_right(char *psp_str, long np_long) { /* updated 2005/05/23, 2005/05/14 */ /* right trim psp_str,np_long into psg_use1,ng_use1 */ long nz; for(nz = np_long - 1; psp_str[nz] <= 32 && nz >= 0; nz--); nz++; tsub_make_long_string(&psg_use1, nz); if(ig_exit != 1) { tsub_copy(psg_use1, psp_str, nz); ng_use1 = nz; } } /* tsub_use_trim_right */ void tsub_use_delete21(long np_beg, long np_long) { /* updated 2005/05/23 */ /* beginning at np_beg delete np_long in psg_use2,ng_use2 */ /* put in psg_use1,ng_use1 */ long n_part2beg, n_part2_lg; int i_good = 1; if(np_beg < 0 || np_long < 1 || np_beg >= ng_use2) i_good++; if(i_good == 1) { /* find start of after deleted */ n_part2beg = np_beg + np_long; /* get length of part to hold */ n_part2_lg = ng_use2 - np_beg - np_long; /* make a string to psg_use1 */ tsub_make_long_string(&psg_use1, ng_use2 - np_long); if(ig_exit == 1) i_good++; } if(i_good == 1) { tsub_copy(psg_use1, psg_use2, np_beg); tsub_copy(&psg_use1[np_beg], &psg_use2[n_part2beg], n_part2_lg); ng_use1 = ng_use2 - np_long; } } /* tsub_use_delete21 */ void tsub_pass_delete(long np_beg, long np_long) { /* updated 2005/07/19, 2005/05/12, 2005/05/11, 2005/05/10, 2004/12/09 */ /* long */ char *ps_hold = NULL; long n_holdbeg, n_hold_lg; int i_good = 1; int i_mustfree = 2; if(np_beg < 0 || np_long < 1 || np_beg >= ng_pass_lg) i_good++; if(i_good == 1) { /* find start of after deleted */ n_holdbeg = np_beg + np_long; /* get length of part to hold */ n_hold_lg = ng_pass_lg - n_holdbeg; if(n_holdbeg >= ng_pass_lg) { /* delete goes to end or beyond */ ng_pass_lg = np_beg; i_good++; } } if(i_good == 1) { /* make a string to hold */ tsub_make_long_string(&ps_hold, n_hold_lg); if(ig_exit == 1) i_good++; else i_mustfree = 1; } if(i_good == 1) { tsub_copy(ps_hold, &sg_pass[n_holdbeg], n_hold_lg); tsub_copy(&sg_pass[np_beg], ps_hold, n_hold_lg); ng_pass_lg = ng_pass_lg - np_long; } /* free long string in ps_hold */ if(i_mustfree == 1) free(ps_hold); } /* tsub_pass_delete */ void tsub_pass_insert(long np_beg, char *sp1, long np_long) { /* updated 2005/05/11, 2005/05/10, 2005/02/12, 2004/12/08 */ /* long */ /* insert string sp1,np_long in front of byte np_beg of sg_pass */ char *ps_hold = NULL; long n_hold_lg; int i_good = 1; int i_mustfree = 2; if(np_beg < 0) np_beg = 0; if(np_beg > ng_pass_lg) np_beg = ng_pass_lg; /* get n_hold_lg the length of ps_hold */ n_hold_lg = ng_pass_lg - np_beg; /* create string ps_hold for length n_hold_lg */ tsub_make_long_string(&ps_hold, n_hold_lg); if(ig_exit == 1) i_good++; else i_mustfree = 1; if(i_good == 1) { tsub_copy(ps_hold, &sg_pass[np_beg], n_hold_lg); /* put in from sp1 into sg_pass */ tsub_copy(&sg_pass[np_beg], sp1, np_long); /* put the ending from s_hold into sg_pass */ tsub_copy(&sg_pass[np_beg + np_long], ps_hold, n_hold_lg); ng_pass_lg = ng_pass_lg + np_long; } /* free ps_hold if needed */ if(i_mustfree == 1) free(ps_hold); } /* tsub_pass_insert */ void tsub_pass_trim_left(void) { /* updated 2005/05/10, 2005/02/12 */ /* long */ /* trim left on sg_pass,ng_pass_lg */ long ny, nz; char sz[VSLONG]; /* blank sz */ tsub_blank(sz, VSLONG); /* find beginning of sg_pass to iz */ for(nz = 0; nz < VSLONG && sg_pass[nz] <= 32; nz++); /* copy left trimmed sg_pass to sz */ for(ny = 0; nz < ng_pass_lg; nz++, ny++) sz[ny] = sg_pass[nz]; /* put new length in ng_pass_lg */ ng_pass_lg = ny; /* copy from sz back to sg_pass */ tsub_copy(sg_pass, sz, VSLONG); } /* tsub_pass_trim_left */ void tsub_pass_trim_right(void) { /* updated 2005/05/10, 2005/02/19, 2005/02/12 */ /* long */ /* trim right on sg_pass,ng_pass_lg */ long nz; for(nz = ng_pass_lg - 1; sg_pass[nz] <= 32 && nz >= 0; nz--); ng_pass_lg = nz + 1; } /* tsub_pass_trim_right */ /* c90tea.cpp is an interpreter of the Teapro programming language */ /*