 
//Was: #ifdef FOR_OS_WINDOWSNT 
#ifdef FOR_OS_WINDOWSNT
#	include <sys/timeb.h>
#endif
#ifdef BY_GCC_MINGW_WIN 
#	include <sys/timeb.h>
#endif

#ifdef BY_GCC_MINGW_WIN
  /* For the function rf_getLang below. */
# include <windows.h>
#endif

# include "decl.h"
# include "macros.h"
# include "fileio.h"
# include "ifunc.h"
# include "fileio.h"

// Nemytykh, 27.09.2022
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
 
#include "version.h"


#ifdef FOR_OS_WINDOWSNT
/* For _stat () */
#	include <sys/types.h>
#	include <sys/stat.h>
/* For _getcwd () */
#	include <direct.h>
/* For getpid () */
#	include <process.h>
#else
/* For stat () */
#	include <sys/stat.h>

/* For stat (), getcwd () */
#	include <unistd.h>


/* For 	WIFEXITED, WEXIATUS */
#	include <sys/types.h>
               // 7777, Nemytykh, 13-04-2025
#ifndef BY_GCC_MINGW_WIN
#	include <sys/wait.h>
#endif

#       define  MAX_PATH_LEN 1024
#       ifdef FOR_OS_DOS
#               define _MAX_PATH 1024
#       endif
#endif

#include <time.h>
#include <stdlib.h>
#include <errno.h>

# define MDEBUG 0
# define MDEBUG1 0

  /* For translator pgraph */
extern unsigned REFLONG ul_local_calls;
extern int flag_local_calculation;


int rf_prout (char outputUNPR)
	/* RF_PROUT prints its argument onto standart output file
		and returns empty. Format :
		<Prout  e.arg>	*/

	{
	check_freeze;

   outUnprn = outputUNPR; 
	if (NEXT(b1) != b2) ri_put (stdout,std_streem_fmodes[R_STDOUT]);
	outUnprn = YES;
   putc ('\n', stdout); 
	rdy (0);
	out (2);
	est;
	return 0;
	}


int rf_put ()
	/* RF_PUT prints the second argument onto file REFALxx.DAT, 
		where xx is the first argument (must be a MACRODIGIT)
		and returs the second argument. Format :
		<Put s.digit e.expr>	*/

	{
	int i;
	char s [11], mode;
	FILE *f;

	check_freeze;

	b1 = b1->foll;
	if (!LINK_NUMBER (b1)) goto restart;
	i = (b1->pair.n) % FILE_LIMIT;
	if (i == 0) f = stderr;
	else
		{
		if (file_table [i] == NULL)
			{
			sprintf (s, "REFAL%d.DAT", i);
			ri_open (i, "w", s);
			};
		f = file_table [i];
      mode = fmode_table [i][1];
		if( (f == stderr) ) mode = std_streem_fmodes[R_STDERR];
		};
	tbel (3) = ((b1->foll == b2) ? NULL : b1->foll);
	tbel (4) = b2->prec;
	if (tbel (3) != NULL) ri_put (f,mode);
//+  	putc ('\n', f);
   ri_putc_enc_nl(f, mode);

	rdy (0);
	tple (4);
	out (2);
	est;
	return 0;

	restart:
		return ri_imp ();
	}


/* BR: transplant the argument to the stock.	
   Format: <Br e.Name'=' e.Expr> 
*/
int rf_br (void) {
	LINK * lnkp_w;

	check_freeze;

	/* Check arguments */
	for (lnkp_w = b1 -> foll; lnkp_w != b2; lnkp_w = lnkp_w -> foll) {
		if (LINK_CHAR (lnkp_w) && lnkp_w -> pair.c == '=') {
			break;
		}
	}

/*
	if (lnkp_w == b2) {
		ri_error (8);
		exit (1);
	}
*/
	if (lnkp_w == b2) goto restart;

	cl;
	b = stock;
	rend = b->foll;
	bl;
	tple (4);
	br;
	weld (b, rend);
	rdy (0);
	out (2);
	est;
	return 0;

	restart:
		return ri_imp ();
}


/* (27) Putout ::= rf_putout (YES), (66) Write ::= rf_putout (NO) */
int rf_putout (char outputNL)
	/* Whenever there is no file associted with the descriptor s.first, then  
	   RF_PUTOUT prints the second argument onto file REFALxx.DAT, 
		where xx is the first argument (must be a MACRODIGIT)
		and returns the empty. 
		The outputNL option availabel only from C-language is a boolen value
		signalising about either needness or absent for outputing the new-line character
		at the end of the second argument.
		Refal-5 Format : <Putout s.first e.second>	
	*/

	{
	int i;
	char s [11], mode;
	FILE *f;

	check_freeze;

	b1 = b1->foll;
	if (!LINK_NUMBER (b1)) goto restart;
	i = (b1->pair.n) % FILE_LIMIT;
	if (i == 0) f = stderr;
	else
		{
		if (file_table [i] == NULL) {
			sprintf (s, "REFAL%d.DAT", i);
			ri_open (i, "w", s);
 		} else if( !((fmode_table [i][0] == 'w') || (fmode_table [i][0] == 'a')) ) {
			fprintf(stderr,"can\'t write the file associated with descriptor %d, open as \'%c\'.\n",i, fmode_table [i][0]);
			goto restart;
		}
		f = file_table [i];
      mode = fmode_table [i][1];       /* The order of this and the following lines does matter. */
		if( (f == stderr) ) mode = std_streem_fmodes[R_STDERR];
		};
	tbel (3) = ((b1->foll == b2) ? NULL : b1->foll);
	tbel (4) = b2->prec;
	if (tbel (3) != NULL) ri_put (f,mode);
	if (outputNL == YES) {
//	printf("\nrf_putout (outputNL = %d), mode = %d ",outputNL, mode);
//	getchar();
//+		putc ('\n', f);
      ri_putc_enc_nl(f, mode);
	} 
	rdy (0);
	out (2);
	est;
	return 0;

	restart:
		return ri_imp ();
	}


int rf_card (void) {
	char mode;

	check_freeze;
   mode = is_get_option(0); /* The arguments signals on a call from an input function. */
	if (IS_IMP(mode)) goto restart; 
	cl;
	
	/*Was: if (tbel (3) == NULL) / * no argumets * /, Nemytykh 28.09.2022 */
	if ( (tbel (3) == NULL) || LINK_COMPSYM (PREV(b2)) ) /* no argumets or only s.mode , Nemytykh 28.09.2022 */
   { 
       return ri_get (stdin,mode,FORBIDDEN_STREAM_MARKER); // See the function ri_get (refio.c) for comments on the last argument.
   }
   else
   restart:
	     return ri_imp ();
}

/* RF_PRINT prints its argument onto standart output file and returns the argument. 
   Format : <Print  e.arg> */
int rf_print (void) {
	check_freeze;

	tbel (3) = ((b1->foll == b2) ? NULL : b1->foll);
	tbel (4) = b2->prec;
	if (tbel (3) != NULL) ri_put (stdout,std_streem_fmodes[R_STDOUT]);
	putc ('\n', stdout);
	rdy (0);
	tple (4);
	out (2);
	est;
	return 0;
}

/*
static int
is_function (char * cp_id) {
	char ** cpp_w, * cp_func;

	for (cpp_w = local_functions; * cpp_w != NULL; cpp_w ++) {
		for (cpp_w ++; * cpp_w != NULL; cpp_w ++) {
			for (cp_func = (* cpp_w) - 2; * cp_func != 0; cp_func --);
			cp_func ++;
			if (0 == strcmp (cp_func, cp_id)) {
				return 1;
			}
		}
	}
	return 0;
}
*/

/*   Format : <Type e.Expr> => s.Type s.Subtype e.Expr  */
int rf_type (void) {
	char c [3] = {'\0', '0', '\0'}, x, i;
	utf u;
	cl;
	if (tbel (3) == NULL) c [0] = '*';
	else {
		x = tbel (3)->ptype;
		switch (x) {
		case LINK_TYPE_LSTRUCTB:
			c [0] = 'B';
			break;
		case LINK_TYPE_CHAR:
			i = tbel (3)->pair.c;
			if (isupper(i)) {
				c [0] = 'L'; c [1] = 'u';
			} else if (islower(i)) {
				c [0] = 'L'; c [1] = 'l';
			} else if (isdigit(i)) {
				c [0] = 'D';
			} else if (' ' <= i && i <= 127) {
				c [0] = 'P';
				c [1] = (isupper (i))? 'u': 'l';
			} else {
				c [0] = 'O';
				c [1] = (isupper (i))? 'u': 'l';
			}
			/*
			ascii = ((line[i] & 128)? 0 : 1)
			utf = 0xc0 & c[0] == 0xc0
			*/
			break;
		case LINK_TYPE_COMPSYM:
			c [0] = 'W';
/*  Nemytykh		if (isalpha (tbel (3) -> pair.f [0])) { */
			if (isIdentifier  (tbel (3) -> pair.f )) { 
				c [1] = 'i';
			} else {
				c [1] = 'q';
			}
			break;
		case LINK_TYPE_NUMBER:
			c [0] = 'N';
			break;
		case LINK_TYPE_MSYMBOL:
			u = tbel (3)->pair.u;
			
			c [0] = 'U'; c [1] = ri_alphabet(u); /* Nemytykh */
			        /* c [0] = 'U' -- UTF-8 ;  
			           c [0] = 'H' is reserved for UTF-16 ;
			           c [0] = 'F' is reserved for UTF-32 ;
			           Here it should checked what is the unicode type is used.
			           May be the correct result should be: Type 'U' Subtype '8' -- UTF-8; 
			                                                        Subtype '6' -- UTF-16; -- The last digit of the name.
			                                                        Subtype '2' -- UTF-32; -- The last digit of the name.
			                                                        Subtype 'u' -- Unicode numbering
			        */
			break;
		case LINK_TYPE_SVAR:
		case LINK_TYPE_TVAR:
		case LINK_TYPE_EVAR:
                case LINK_TYPE_MLSTRUCTB:
                        return ri_frz (1);
/*
		case LINK_TYPE_SVAR:
			c [0] = 'S';
			break;
		case LINK_TYPE_EVAR:
			c [0] = 'E';
			break;
		case LINK_TYPE_TVAR:
			c [0] = 'T';
*/
		default:
			ri_error(10);
			return 1;
		}
	}
	rdy (0);
	{
		int i_w;

		for (i_w = 0; c [i_w] != '\0'; i_w ++) ns (c [i_w]);
	}
	tple (4);
	out (2);
	est;
	return 0;
}

/*
void ri_cs(char * str) {
	char *pc = ri_cs_impl (str);
	rdy (0);
	ncs (pc);
	return;
}
*/
void ri_cs(char * str) {
	char *pc = ri_cs_impl (str);
	ncs (pc);
	return;
}

void empty_parenthesis(void) {
	bl; br;
	return;
}
/*   Format : <UType s.Usymbol> => s.Alphabet s.Language s.Subtype e.Other  
      s.Subtype ::= s.UpperRegister | s.LowRegister | s.Numeral ...
*/
int rf_utype (void) {
	char x;
	
	all;
	cl;
   rdy (0);
	if (tbel (3) == NULL) {
       ri_cs("Empty");
       empty_parenthesis();
	} 
	else {
		x = tbel (3)->ptype;
		switch (x) {
		case LINK_TYPE_MSYMBOL:
			ri_cs("UChar");
			ri_alpha_props(tbel (3)->pair.u);
			break;
		case LINK_TYPE_CHAR:
			ri_cs("ASCII");
			empty_parenthesis();
			break;
		case LINK_TYPE_COMPSYM:
			ri_cs("Word");
			empty_parenthesis();
			break;
			
		default:
			ri_cs("Other");
			empty_parenthesis();
		}
	}
	tple (4);
	out (2);
	est;
	return 0;
}

void ri_alpha_props (utf u) {
	char * p;
		
	bl;
	ri_cs(ri_alphabet_s(u));
	if ( u == ri_tolower (u) ) { ri_cs("Lower"); }
	else { ri_cs("Upper"); }

	if ( ri_isIndex(u) ) {
		ri_cs("Index");
		ri_cs( IndexCase(u) );
		ri_cs( IndexAlphabet(u) );
	} else { 
	   p = ri_NumericType(u); 
	   if ( p != NULL ) { 
	      ri_cs("Numeric");
	      ri_cs(p); 
	      p = ri_DigitType(u);
	      if ( p != NULL ) ri_cs( p );
	      else goto Other;
	} 
	int i = ri_isWhiteSpace(u);
	if ( i > 0 ) { 
	   p = ri_WhiteSpaceType(u);
	   if ( p != NULL ) { 
	      ri_cs("WhiteSpace");
	      ri_cs(p); 
	      if( i == 1 ) { p = ri_WhiteSpaceWidth(u);
	                     if ( p != NULL ) ri_cs( p );
	                     else goto Other; }
	      else { u = ri_WhiteSpaceLength(u);
	             mns(u); }
	      /* else goto Other; */
/*	   } else {
	   	if ( u == ri_tolower (u) ) { ri_cs("Lower"); }
	   	else { ri_cs("Upper"); } */
 /* utf ch = ri_toupper (b1->pair.u); */
 /*        ri_tolower (u); */
	   } else {
	     Other: ri_cs("Other");
	   }
	}
   }
	br;
	return;
}


/*   Format : <Dg e.Name> => e.Expr  */
int rf_dg ()
	{
	LINK *end;

	check_freeze;
/*	check_frz_args (1); Nemytykh 02.02.2006 */

	cl;
	b1 = stock->foll;
	end = stock->pair.b;
	while (b1 != end)
		{
		tbel (5) = b1;
		tbel (6) = b2 = b1->pair.b;
		nel=7;
		oexp (4);
		sym ('=');
		cl;
		rdy (0);
		tple (11);
		out (2);
		b = tbel (5)->prec;
		out (6);
		est;
		return 0;

	restart:  
		sp++;
		b1 = tbel (6)->foll;
		};

	rdy (0);
	out (2);
	est;
	return 0;
	}

/*   Format : <Get s.digit> => e.Expr  */
int rf_get ()
	{
	/*register*/ int i;
	char s [11];
	char mode;

   check_freeze;
	b1 = b1->foll;
   mode = is_get_option(1); /* The argument signals on this call from the input function. */
	if ( ! LINK_NUMBER (b1) || IS_IMP(mode) )  goto restart;
	i = (b1->pair.n) % FILE_LIMIT;
	if (i == 0) ri_get (stdin, mode,FORBIDDEN_STREAM_MARKER); // See the function ri_get (refio.c) for comments on the last argument.
	else
		{
		if (file_table [i] == NULL)
			{
			sprintf (s, "REFAL%d.DAT", i);
			ri_open (i, "r", s);
			};
		if( fmode_table [i][0] != 'r' ) {
			fprintf(stderr,"can\'t read the file associated with descriptor %d, open as \'%c\'.\n",i, fmode_table [i][0]);
			goto restart;
		}
		if(mode == ENC_UNKNOWN) mode = fmode_table [i][1];
		ri_get (file_table [i], mode, i); // See the function ri_get (refio.c) for comments on the last argument.
		};
	return 0;

	restart:
		return ri_imp ();
	}


/* Format : <Arg s.digit> => e.Expr */
/* Nemytykh, 21-03-2023 */
int rf_arg ()
	{
	/*register*/ int i, ln;
	char *c;
	char mode;

   check_freeze;
	b1 = b1->foll;
   mode = is_get_option(1); /* The argument signals on this call from the input function. */
//?   mode = is_get_option(0); /* The argument signals on a call from the explode function. */
	if ( ! LINK_NUMBER (b1) || IS_IMP(mode) )  goto restart;
	rdy (0);
	
	i = b1->pair.n;
	if(i < gargc) {
	   c = r__wgetarg(garg[i],i+1);
   	if( mode == ENC_FLAT ) { 
   	  	for ( ; *c != '\0'; c++) { 
       	  if ( * c < 128 ) 
              { ns (* c); }                   /* byte ASCII char     */
           else {                             /* unicode char        */
		          utf u = r_int_to_utf(* c);
		          mns (u);
           }
  	      }
   	}
   	else {  /* I.e., this mode is by default. */ 
		   for (; *c != '\0'; c++) {
			   ln = ri_getc (c, ENC_NONFLAT);
			   c += ln;
		   }
	   }
	} 
	
	out (2);
	est;
	return 0;

	restart:
		return ri_imp ();
	}

char *mu_find (char *str, char **pi) {
	char *pc;

	/*pi ++;*/ /* skip the title. */
	for (pi ++; *pi != NULL; pi ++) {
		pc = *pi;

		if (pc [-1] != '\0') {
			fprintf (stderr, "WARNING: Uncorrect format names(MU_FIND)\n");
		}
		for (pc -= 2; * pc != '\0'; pc --);
		pc ++;

		/*if (strncmp (str, pc - MAXWS, MAXWS) == 0) return pc;*/
		if (strcmp (str, pc) == 0) {
			for (; * pc != '\0'; pc ++);
			pc ++;
			return pc;
		}
		/*pi ++;*/
	}
	return NULL;
}
	
/* RF_MU accepts 2 formats:
 *	<Mu (e.STRING) e.ARG>
 *	<Mu s.SYMBOL e.ARG>
 * The result is <F e.ARG>, where F is the function whose name
 * is the same as the STRING in the first case or SYMBOL in the second.
 */
/* pointer to the beginning of the list of functions visible from this module. */
int rf_mu (char ** muaddr, int freeze_flag) {
	char str [MAXWS+1], *pc;
	int i;

	if (freeze_flag) check_freeze;
	i = 0;
	b1 = b1->foll;
	if (LINK_VAR (b1) || GPAR (b1)) goto call_freeze;
	/* first format */
	if (LINK_LSTRUCTB (b1)) {
		b1 = b1 -> foll;
		if ( LINK_CHAR (b1) && mu_special (str, b1->pair.c) == 0) {/* special symbol */
			b1 = b1 -> foll;
			i++;
		} else {
	   	/* copy the string into array str []; */
	   	for ( ; LINK_CHAR (b1) || LINK_MSYMBOL (b1) ; b1 = b1 -> foll) {
	   		

/*     Actually the final decision will take mu_find function. It means that the following checking may be omitted. Nemytykh 18-04-2023
            c = b1->pair.c;
		   	if (isalnum (c) || c == '_' || c == '$' || c == '-' || isdigit (c)) str [i++] = c;
		   	else goto call_ri_imp;
*/		   	
            if (LINK_CHAR (b1)) str [i++] = b1->pair.c;
            else /* if(LINK_MSYMBOL (b1))*/ { 
			     int j = ri_utf_explode(b1 -> pair.u, (char *)str + i, MAXWS-i);
			     if ( j == -1 ) { return ri_frz (3); }
		        else { i += j+1; }
            }

/* Nemytykh 08.10.2019, Was:			if (i >= MAXWS) return ri_error (7); */
                        if (i >= MAXWS) return ri_frz (3);  
	   	}
		   str [i] = '\0';
	   }
		if (LINK_VAR (b1) || GPAR (b1)) goto call_freeze;
		/* check that the string is not empty. */
		if (i == 0) goto call_ri_imp;
		/* check that b1 now points to a right parenthesis. */
		if (!LINK_RSTRUCTB (b1)) { goto call_ri_imp; }
	} else if (LINK_COMPSYM (b1)) { /* second format */
	   if ( (mu_special (str, *(b1->pair.f)) == 0) && (*((b1->pair.f)+1) == '\0') ) {
	   	;
	   } else {
/* The following checking may be omitted as well. See a comment above. Nemytykh 18-04-2023. */	   	
	   	if ( isIdentifier (b1 -> pair.f) == 1 ) {
            strcpy (str, b1->pair.f);
	   	} else { goto call_ri_imp; };
	   }
	} else if (LINK_SYMBOL (b1) && mu_special (str, b1->pair.c) == 0) {/* special symbol */
		;
	} else { /* we got here if the function with the same name was not found. */ 
/* Nemytykh 07.10.2019
 Was:		ri_error (7);
		return 1;
*/
		call_ri_imp: return ri_imp ();
	}
	/* Now b1 points just before the argument. e.ARG. */
	cl;
	/* Get the address of the function stored in str. */
	pc = mu_find (str, muaddr);
	if (pc == NULL) pc = mu_find (str, entry_functions);
	if (pc != NULL) {
		/* the function is found. */
		rdy (0)
		bl;
		tple (4);
		br;
		act1 (pc);
		out (2);
		est;
		return 0;
	} else {/* we got here if the function with the same name was not found. */
		ri_error (7);
		return 1;
	}

call_freeze:

	return ri_frz (1);
}

	/* check if c_value is a special acceptable value for arithmetic
		function. Return 0 if success, 1 = failure
		Important: if FAIL, do NOT overwrite s_value */

int mu_special (char *s_value, char c_value) {
	switch (c_value) {
	case '+':
		strcpy (s_value, "Add");
		break;

	case '-':
		strcpy (s_value, "Sub");
		break;

	case '*':
		strcpy (s_value, "Mul");
		break;

	case '/':
		strcpy (s_value, "Div");
		break;

	case '%':
		strcpy (s_value, "Mod");
		break;

	case '?':
		strcpy(s_value, "Residue");
		break;

	default:
		return 1;	/* failure */
	}
	return 0;	/* success */
}



# define utf8str_from_rfsymbolseq_in_bltfarg(dst)       {\
   char * tmp__cp, *tmp__p;\
	for (tmp__cp = dst, b1 = b1->foll; b1 != b2; b1 = b1 -> foll) {\
		if (LINK_CHAR (b1)) { *tmp__cp++ = b1->pair.c; } \
		else if(LINK_MCHAR (b1)) { \
			tmp__p = r_utf_expl(b1->pair.u); \
			while (*tmp__p) { *tmp__cp++ = *(tmp__p++); } \
		} else ri_imp (); \
	}; \
	* tmp__cp = '\0';\
	}

/*   Format : <GetEnv e.characters> => e.Expr  */
// 777777
int rf_getenv (void) {
//	char ca_buf [256]; 
	char ca_buf [ENV_VARVALUE_MAX+3];
	char * cp;

	check_freeze;

/* Was:
	for (cp = ca_buf, b1 = b1->foll; b1 != b2; b1 = b1 -> foll, cp ++) {
		if (! LINK_CHAR (b1)) return ri_imp ();
		* cp = b1 -> pair.c;
	}
*/ // Данный ниже цикл вынести в отдельный макрос или функцию. См. также rf_open.
/* [ Nemytykh, 06-08-2025	*+/
	for (cp = ca_buf, b1 = b1->foll; b1 != b2; b1 = b1 -> foll) {
		if (LINK_CHAR (b1)) { *cp++ = b1->pair.c; }
		else if(LINK_MCHAR (b1)) {
			p = r_utf_expl(b1->pair.u);
			while (*p) { *cp++ = *(p++); }
		} else ri_imp ();
	}
/+* ] Nemytykh, 06-08-2025	*/
   utf8str_from_rfsymbolseq_in_bltfarg(ca_buf);
	rdy (0);
	char mode = ENC_UTF_8; 
	if (NULL != (cp = r_wgetenv (ca_buf))) {
		for (int i = 0; * cp != 0; cp += (i+1)) {
			i = ri_getc (((char *)cp),mode);
		};
	}
	out (2);
	est;
	return 0;
}

/* Get current process id. A.A. Vladimirov 10.10.2004 */
/*   Format : <GetPID> => s.number  */
int rf_getpid (void) {

	check_frz_args (1);

	b1 = b1->foll;
	if (b1 != b2) return ri_imp ();
	rdy (0);

	nns ((unsigned REFLONG) getpid());
	out (2);
	est;
	return 0;
}

/* Get parent process id. A.A. Vladimirov 10.10.2004.
   This function is undefined under Windows operating sysytem.
   In fact, it returns current process id. 
*/
/*   Format : <GetPPID> => s.number  */
int rf_getppid (void) {
        unsigned REFLONG i;

	check_frz_args (1);

	b1 = b1->foll;
	if (b1 != b2) return ri_imp ();
	rdy (0);
# if FOR_OS_WINDOWSNT || BY_GCC_MINGW_WIN
                         // 77777, Nemytykh 13-04-2025
	i = (unsigned REFLONG) getpid();
# else
  	i = (unsigned REFLONG) getppid();
# endif
        nns(i);
	out (2);
	est;
	return 0;
}

# define ustr_arg(n) 	for (b1 = b1->foll, i=0; (b1 != b2); b1 = b1->foll)\
                     	{  if (i == (n)) return ri_error (1);\	
                     	   if (LINK_CHAR (b1)) { ca_buf[i++] = b1->pair.c; }\
		                     else if(LINK_MCHAR (b1)) {\
			                     cp = r_utf_expl(b1->pair.u);\
			                     while (*cp) { ca_buf[i++] = *(cp++); }\
		                     } else ri_imp ();\
	                     }\
	                     ca_buf [i] = 0;

/*   Format : <System e.characters> => e.sign s.number  */
int rf_system (void) {
	char ca_buf [MAX_SYSTEM_CALL+1];
	int i;
	char * cp;

	check_freeze;
   ustr_arg(MAX_SYSTEM_CALL); /* Nemytykh, 24-02-2023	*/
	i = r_wsystem (ca_buf);
                     // 77777, Nemytykh, 13-04-2025  
#if FOR_OS_LINUX && !BY_GCC_MINGW_WIN
	/* madmax */
	if (WIFEXITED (i) != 0) {
		i = WEXITSTATUS (i);
	} else {
		i = 1;
	}
#endif

	rdy (0);

	if (i < 0) {
		ns ('-');
		i = abs(i);
	}
	nns (i);
	out (2);
	est;

	return 0;
}

extern FILE* ref_err_file();
extern void ri_information (ri_time_strct, int);

/*   Format : <Exit e.return-code>, 
     where e.return-code ::= s.number | '-' s.number | '+' s.number  */
int rf_exit (void) {
	int i = 1, j;
	ri_time_strct l_t;

#ifdef FOR_OS_WINDOWSNT
	_ftime (& l_t);
#else
#  ifdef BY_GCC_MINGW_WIN 
//   REFLONG l_t = time (NULL); 
// Was:  l_t = time (NULL); 
  	_ftime (& l_t);  // 7777, nemytykh 15-04-202
#  else
   // Was: REFLONG l_t = time (NULL); // For Linux x32
             // i.e. FOR_OS_LINUX x64, nemytykh, 05-04-2026
   clock_gettime(CLOCK_REALTIME, & l_t);
#  endif
#endif

	check_freeze;

	b1 = b1 -> foll;
	if (LINK_CHAR (b1)) {
		if (b1 -> pair.c == '-') {
			i = -1;
		} else if (b1 -> pair.c == '+') {
			i = 1;
		}
		b1 = b1 -> foll;
	} else {
		i = 1;
	}
	if (! LINK_NUMBER (b1) || (NEXT(b1) != b2)) return ri_imp ();
	i *= b1 -> pair.n;

	rdy (0);
	/* Print all informations which are wanted to see to user */
	ri_information (l_t, 0);

	for (j = 0; j < FILE_LIMIT; j ++) {
		if (file_table [j] != NULL) {
			fclose (file_table [j]);
		}
	}

	exit (i);
	out (2);
	est;
        return 0;
}

/*   Format : <Close s.digit> => empty */
int rf_close (void) {
	int i;

	check_freeze;

	b1 = b1 -> foll;
	if (! LINK_NUMBER (b1) || (NEXT(b1) != b2))  
                return ri_imp ();
	i = b1 -> pair.n % FILE_LIMIT;
	if (NULL != file_table [i]) {
		fclose (file_table [i]);
		file_table [i] = NULL;
//+		fmode_table [i][2] = EOF; // 7777, Nemytykh, 29-06-2025
		fmode_table [i][2] = EMPTY_MARKER; // 7777, Nemytykh, 29-06-2025
		
	}
	b1 = b2;
	rdy (0);
	out (2);
	est;
	return 0;
}

/*
 If the following two idef the definitions for WindowsNT are valid only for x32 model
 and should be corrected if one wants to compile by Microsoft C for x64 model.
*/
#ifdef FOR_OS_WINDOWSNT
#   define rf_stat _stat
#endif

/*   Format : <ExistFile e.name-string> => s.Boolean */
int rf_existfile (void) {
	char ca_buf [FILENAME_MAX+1];
	char * cp;
	int i;

	check_freeze;

   ustr_arg(FILENAME_MAX); /* Nemytykh, 24-02-2023	*/
   
	{
#ifdef FOR_OS_WINDOWSNT

		if (0 == _stat (ca_buf, & st_buf)) {
			/* Exist */
/* Was:			if (st_buf.st_mode & _S_IFREG) { */
			if ( (st_buf.st_mode & _S_IFREG) || (st_buf.st_mode & _S_IFDIR) ) {  /* Nemytykh, 25-02-2023	*/
				cp = ri_cs_impl ("True");
				goto end;
			} 
#else

		if (0 == r_stat (ca_buf, & st_buf)) {
			/* Exist */
/* Was:			if (st_buf.st_mode & S_IFREG) { */
			if ( (st_buf.st_mode & S_IFREG) || (st_buf.st_mode & S_IFDIR) ) {   /* Nemytykh, 25-02-2023	*/
				cp = ri_cs_impl ("True");
				goto end;
			}
		} 
#endif
		cp = ri_cs_impl ("False");
	}
  end:
	rdy (0);
	ncs (cp);
	out (2);
	est;
	return 0;
}

# ifdef FOR_OS_WINDOWSNT
#    define RF_MAX_PATH_LEN _MAX_PATH
#    define RF_getcwd _getcwd
# else
#    define RF_MAX_PATH_LEN MAX_PATH_LEN
#    define RF_getcwd r_getcwd
# endif

/*   Format : <GetCurrentDirectory> => e.characters  */
int rf_getcurrentdirectory (void) {
	int i;
	char ca_curdir [RF_MAX_PATH_LEN];
	char *p = (char *)ca_curdir;

	check_freeze;
	if (NEXT(b1) != b2) return ri_imp ();

	if (NULL == RF_getcwd (ca_curdir, RF_MAX_PATH_LEN)) {
		fprintf (stderr, "WARNING: Cannot get a current directory\n");
		fprintf (stderr, "No memory for its path.\n");
		ca_curdir [0] = 0;
	}

	rdy (0);
/* Was:
	for (i = 0; ca_curdir [i] != 0; i ++) {
		ns (ca_curdir [i]);
	}
*/
	char mode = ENC_UTF_8; 
	for (i = 0; * p != 0; p += (i+1)) {
		i = ri_getc (p,mode);
	};

	out (2);
	est;
	return 0;
}


/*   Format : <RemoveFile e.file_name-string> => s.Boolean (e.Errors) */
int rf_removefile (void) {
	char ca_buf [FILENAME_MAX+1], * cp, * cp_err;
	int i;

	check_freeze;

   ustr_arg(FILENAME_MAX); /* Nemytykh, 24-02-2023 */

/* Actually this function is able to remove an empty directory, since no validation on ordinary file is done.
   (See the function ExistFile above), Nemytykh, 25-02-2023 )
*/
	if ((b1 != b2) || (-1 == r_fremove (ca_buf))) {
		cp = ri_cs_impl ("False");
        	if (b1 != b2) 
                {
		             b1 = b2;
                   cp_err = "File name is too long.\0";
	              }
                else cp_err = strerror (errno);
	} else {
		cp = ri_cs_impl ("True");
		cp_err = NULL;
	}
	rdy (0);
	ncs (cp); 
	bl;
	if (cp_err != NULL) {
		for (i = 0; cp_err [i] != 0; i ++) {
			ns (cp_err [i]);
		}
	}
	br;
	out (2);
	est;
	return 0;
}

/* Nemytykh */
/*   Format : <Implode_Ext e.string e.expr> => s.compound_symbol-string */
int rf_implodeExt (void) {
	char ca_str [MAXWS + 1], * cp_w;
	int i, j;

	for (i = 0, b1 = b1 -> foll; i < MAXWS && b1 != b2; i ++, b1 = b1 -> foll) {
		if (LINK_VAR (b1) || GPAR (b1)) {
			return ri_frz (1);
		} else if (LINK_CHAR (b1)) {
		   ca_str [i] = b1 -> pair.c;
		} else if (LINK_MSYMBOL (b1)) {
			j = ri_utf_explode(b1 -> pair.u, (char *)ca_str + i, MAXWS-i);
			if ( j == -1 ) { goto err; }
			else { i = i + j; }
		} else break;
	}
	if (i == MAXWS && b1 != b2) {
             err: return ri_error (15);
	}
	ca_str [i] = 0;
	cp_w = ri_cs_impl(ca_str);
	rdy (0);
	ncs (cp_w);
	out (2);
	est;
	return 0;
}


/* The expression between p and q (both are not included) is not empty. */
char is_not_empty(LINK *p, LINK *q) {
	for (p = NEXT(p); p != q; p = NEXT(p)) {
		if ( !(LINK_EVAR (p) || EPAR (p)) ) return 1;
	}
        return 0;
}

/*  Nemytykh, 29.09.2022 */
/* Flat --- Nonflat */
char is_get_option(char req) {
	char * opt;
	char mode;
	LINK *p;
   mode = (req == 0) ? ENC_NONFLAT : ENC_UNKNOWN; /* I.e., this mode is by default. */
	
	p = (req == 1) ? PREV(b2) : NEXT(b1); /* see the definition of the calling functions */
	if ( LINK_COMPSYM (p) ) { /* s.mode - input value, the last argument   */
		opt = p->pair.f;
		if ( strcmp(opt,"Flat") == 0 )        mode = ENC_FLAT;
		else if( strcmp(opt,"Nonflat") == 0 ) mode = ENC_NONFLAT; 
		else { 
		  // b2 = NEXT(b2);
		  mode = IMP; 
		}
	} 
 	return mode;
}

/* Nemytykh, 22-09-2022. */
/*   Format : <Explode_Ext s.compound_symbol-string> => e.string */
int rf_explodeExt (void) {
	char mode;

	b1 = NEXT(b1);
	if (LINK_VAR (b1) || GPAR (b1)) return ri_frz (1);
	else {
		mode = is_get_option(0); /* The argument signals on a call from the explode function. */
	}
	if (! (LINK_COMPSYM (b1) || LINK_MSYMBOL (b1)) || IS_IMP(mode)) return ri_imp ();
	rdy (0);
	
	if( mode == ENC_FLAT ) { ri_explodeExtFlat(); }
	else { ri_explodeExtNonflat(); /* I.e., this mode is by default. */ }
	
	out (2);
	est;
	return 0;
}

void ri_explodeExtNonflat (void) {
	char * cp_w;
//	utf symb;
	int ln;

	if( LINK_COMPSYM (b1) ) { /* Nemytykh, 21-09-2022 */
		cp_w = b1 -> pair.f;
		for ( ; (* cp_w != 0) ; cp_w ++) {
			ln = ri_getc (cp_w, ENC_NONFLAT);
			cp_w += ln;
		}
	} else { /* IS MSYMBOL */
      rend = NEXT(NEXT(b));
      TYPE(lfm) = TYPE(rend); 
      PAIR(lfm) = PAIR(rend);
      ns1;
   }
	return; 
}

void ri_explodeExtFlat (void) {
	char * cp_w;
	utf u;

	cp_w = LINK_COMPSYM (b1) ? b1 -> pair.f : r_utf_expl(b1 -> pair.u); /* Nemytykh, 21-09-2022 */
  	for ( ; * cp_w != 0; cp_w ++) { 
     	 if ( * cp_w < 128 ) 
       { ns (* cp_w); }                   /* byte ASCII char     */
       else {                             /* unicode char        */
		   u = r_int_to_utf(* cp_w);
		   mns (u);
       }
  	}
	return;
}

/*   Format : <TimeElapsed e.init> => e.char-digits '.' e.char-digits 
     , where e.init ::= 0 | empty
       e.char-digits ::= s.digit1 a.digit2 s.digit3 
*/
int rf_timeElaps (void) {
	char /* * cp_time,*/ cu_refTime [50];
	ri_time_strct tm;
	
	sprintf (cu_refTime, "%lu.%03u", (unsigned long) 0,0); /* temprary definition for uknown oper. systems */
	ri_gettime(& tm);
	ri_time ((char *)cu_refTime, tm, ltelaps);
	
	check_freeze;

	if ((b1 = b1 -> foll) != b2) {
		if (!LINK_NUMBER (b1) || is_not_empty(b1,b2)) {
                        return ri_imp ();
		}
		if (b1 -> pair.n == 0) {
         ltelaps = tm;
     }
	}

	rdy (0);

	for (int i = 0; cu_refTime [i] != '\0'; i ++) {
		ns (cu_refTime [i]);
	}

	out (2);
	est;
	return 0;
}

void ri_gettime(ri_time_strct * ptm) {
	
#if defined FOR_OS_WINDOWSNT || defined BY_GCC_MINGW_WIN
	_ftime (ptm);
#else 
# ifdef FOR_OS_LINUX
/* Nemytykh, 20.04.2022, x64 */
// CLOCK_REALTIME, CLOCK_REALTIME_COARSE
// CLOCK_PROCESS_CPUTIME_ID (since Linux 2.6.12), // Per-process CPU-time clock (measures CPU time consumed by all threads in the process).

	clock_gettime(CLOCK_REALTIME, ptm);
# endif
#endif

   return;
}

void ri_time (char * cu_refTime, ri_time_strct tm, ri_time_strct prevtm) {
	unsigned long curr_time;
	int curr_millitm;
	
	sprintf (cu_refTime, "%lu.%03u", (unsigned long) 0,0); /* temprary definition for uknown oper. systems */

#if defined FOR_OS_WINDOWSNT || BY_GCC_MINGW_WIN
	curr_time = tm.time - prevtm.time;
	curr_millitm = tm.millitm - prevtm.millitm;
	if( curr_millitm < 0 ) {
		curr_time--;
		curr_millitm += 1000;
	}
#else 
# ifdef FOR_OS_LINUX
/* Nemytykh, 20.04.2022, x64 */
// CLOCK_REALTIME, CLOCK_REALTIME_COARSE
// CLOCK_PROCESS_CPUTIME_ID (since Linux 2.6.12), // Per-process CPU-time clock (measures CPU time consumed by all threads in the process).

//+	clock_gettime(CLOCK_REALTIME, & tm);
	curr_time = tm.tv_sec - prevtm.tv_sec;
	long curr_nanotm = tm.tv_nsec - prevtm.tv_nsec; // 1 millisecond = 10^6 nanoseconds
	if( curr_nanotm < 0 ) {
		curr_time--;
		curr_nanotm += 1000000000;               // 10^6*10^3 = 1000 000 000
	}
	curr_millitm = curr_nanotm/1000000;     // 10^6 = 1000 000; Just cutting the remainder. (I.e it is a rough rounding.)
	if ( curr_nanotm%1000000 >= 500000 ) {    
		if ( curr_millitm < 999 ) {
			curr_millitm++;
		} else {
			curr_millitm = 0;
			curr_time++;
		}
	}
# endif
#endif

	sprintf (cu_refTime, "%lu.%03u", curr_time, curr_millitm);
	return;
}

void ri_init_time(void) { 
#  if defined FOR_OS_WINDOWSNT || defined BY_GCC_MINGW_WIN
// errno_t _ftime64_s( struct __timeb64 *timeptr );
	_ftime (& whens);
        srand( (unsigned int)(whens.time) );
# else
#    ifndef FOR_OS_WINDOWSNT   
             // i.e. FOR_OS_LINUX x64, nemytykh, 05-04-2026, 77777
	    clock_gettime(CLOCK_REALTIME, & whens);
	    srand((unsigned int)whens.tv_nsec);
#    else
            // i.e. FOR_OS_LINUX x32, nemytykh, 05-04-2026
	     whens = time(NULL);
        srand(time(NULL));
//?        srand((unsigned int)whens);
#    endif
# endif

   ltelaps = whens;
   return;	
}

/* Format: <Interrupt s.when e.how> ==> s.previous_when e.previous_how 
            where s.when ::= s.number_of_steps
                    s.number_of_steps is a macrodigit N standing for upper bound of the Refal-5 machine steps,
                                      counting from the Interrupt call; here N == 0 stands for infinity.
                  e.how  ::= "Undoubtedly" | []
                              The option "Undoubtedly" forbids the following calls of Interrupt to increase
                              the number of the Refal-5 machine steps left of the bound imposed by the current Interrupt call.
                              That is any regular UNDOUBTEDLY bound value can be decreased, but cannot increased.
                              Any attempt to increase such a bound will lead to ignoring the first argument of 
                              the corresponding Interrupt call.
                  s.previous_when is the number N of the Refal-5 machine steps left of the bound imposed 
                                     by the previous Interrupt call. Recall that N == 0 stands for infinity.
                                     If the current Interrupt call is the first of such calls, then s.previous_when == 0.
                  e.previous_how stands for the value of the second argument of the prevous Interrupt call.
                                 If the current Interrupt call is the first of such calls, then e.previous_how is the empty expression.
*/
int rf_interrupt () 
	{
	char * cp;
	unsigned REFLONG n;
   int next_st = INTERRUPT_MAY_BE_CANCELLED;
   char out_flag = 0;

	check_freeze; /* This function with a side effect */
	
	b1 = b1->foll;	/* Get a bound for the number of Refal-machine steps. */
	if (!LINK_NUMBER (b1)) goto restart;
	n = b1 -> pair.n;
   b1 = b1->foll;
	if ( LINK_COMPSYM (b1) && (strcmp (b1 -> pair.f, "Undoubtedly") == 0) ) {
		if ( interrupt_st != INTERRUPT_UNDOUBTEDLY ) next_st = INTERRUPT_UNDOUBTEDLY;
      b1 = b1->foll;
	};
	if ( b1 != b2 ) goto restart;
	
	rdy (0);
	nns(interrupt_bound);

   if ( interrupt_st == INTERRUPT_UNDOUBTEDLY ) { out_flag = 1; }
   if ( ((interrupt_bound == 0) && (next_st == INTERRUPT_UNDOUBTEDLY) ) ) {  
   	interrupt_st = INTERRUPT_UNDOUBTEDLY; 
   	interrupt_bound = n; // the first UNDOUBTEDLY bound value after zero.
   } else if ( (interrupt_bound > n) && out_flag  ) {
   	if ( n ) interrupt_bound = n; // Any regular UNDOUBTEDLY bound value can be decreased, but cannot increased,
   	                              // while n = 0 stands for infinity.
   } else if ( out_flag == 0 ) {
   	interrupt_st = next_st; 
   	interrupt_bound = n; 
   }
   
	if ( out_flag ) {
		cp = ri_cs_impl ("Undoubtedly");
   	ncs (cp);
	}
	out (2);
	est;
	return 0;

	restart:
		return ri_imp ();
	}


/*   Format : <OSname> => e.info-on-operating-system-name */
int rf_OSname () {
	check_freeze;

	cl;
	if (tbel (3) != NULL) return ri_imp ();
   char buffer[512]; 
	
# ifdef BY_GCC_MINGW_WIN 
   char * cp = "ver";	
# else
#  ifdef FOR_OS_LINUX
   char * cp = "uname -o";	
#  endif
# endif

	    // lauch a command (for example, "dir" or "ls -l")
   FILE * fp = popen(cp, "r");
   if (fp == NULL) {
     ri_error(18);
   }

   int ln = 0;
   while (fgets(buffer, sizeof(buffer), fp) != NULL) {
       if ( (ln = strlen(buffer)) > 2 ) break;
   }

	rdy (0);
   for ( int i = 0; ln > i ; i++) {
   	if ( (buffer[i] == '\n') || (buffer[i] == '\r') ) break;
   	ns ( buffer[i] );
   }
	out (2);
	est;
	return 0;
}

	     // Nemytykh 12-03-2026
/*   Format : <GetLang> => e.info-on-lanuguage 
     Example:              ru_RU.UTF-8 (так в LINUX-е выглядит значение LANG),
                           cu_RU.UTF-8 (церковно-словянский),
        образцы для отождествления: 'ru_' s.R s.U '.UTF-8'
                                     e.ru '_RU.UTF-8'
                           ru_BY.UTF-8, be_BY.UTF-8 (белорусские),
                           ru_UA.UTF-8, uk_UA.UTF-8 (украинские),
                           ru_MO.UTF-8 (Приднестровье, русский),
                           bg_BG.UTF-8 (болгарский), sr_RS.UTF-8 (сербский),
        образцы для отождествления: 'sr_' s.R s.S '.UTF-8'
                           mk_MK.UTF-8 (македонский), 
        образцы для отождествления: e.sr '_ME'.UTF-8'
                           sr_ME.UTF-8, cnr_ME.UTF-8 (черногорские)
                           kk_KZ.UTF-8 (казахский), ky_KG.UTF-8 (кригизский),
                           hy_AM.UTF-8 (армянский), ka_GE.UTF-8 (грузинский)
*/
int rf_getLang () {
   char * p;
	check_freeze;


	cl;
	if (tbel (3) != NULL) return ri_imp ();
	
# ifdef BY_GCC_MINGW_WIN 
   unsigned int outCP = GetConsoleOutputCP();
   unsigned int inCP = GetConsoleCP();

   if (outCP != inCP) {
     ri_error(19);
   }

   p = ri_UserLocaleName();
   char * CodePageName = ri_CodePageIdnt (outCP);
# else
#  ifdef FOR_OS_LINUX
   if ( (NULL == (p = getenv ("LANG"))) ) { p = ""; }
#  endif
# endif

	rdy (0);
       // ru_RU.UTF-8 (так в LINUX-е выглядит значение LANG)
   for ( ; *p ; p++) { ns (*p); }
# ifdef BY_GCC_MINGW_WIN 
   ns('.');
   for ( p = CodePageName; *p ; p++) {	ns (*p); }
# endif
	out (2);
	est;

	return 0;
}

/* The following function is a rudiment and not updated for unicode.
   Nemytykh, 27-08-2025
*/
int rf_XMLParse (void) {
  char cu_file [FILENAME_MAX];
  int i;
  FILE * fp_in, * fp_out;

  for (i = 0, b1 = b1 -> foll; b1 != b2; b1 = b1 -> foll, i ++) {
    if (! LINK_CHAR (b1)) {
      ri_error (8);
      return 1;
    }
    cu_file [i] = b1 -> pair.c;
  }
  cu_file [i] = 0;
  if (NULL == (fp_in = fopen (cu_file, "r"))) {  // REFAL5XML
    fprintf (stderr, "Cannot open file \'%s\'.\n", cu_file);
    exit (1);
  }
  if (NULL == (fp_out = fopen ("REFAL5XML", "w"))) {
    fprintf (stderr, "Cannot open file \'REFAL5XML\'\n");
    exit (1);
  } 
  if (0 != ri_xml2ref (fp_in, fp_out)) {
    weld (b, rend);
    ri_error (8);
    fclose (fp_in);
    return 1;
  }
  fclose (fp_out);
  if (NULL == (fp_out = fopen ("REFAL5XML", "r"))) {  // REFAL5XML
    fprintf (stderr, "Cannot open file \'REFAL5XML\'.\n");
    exit (1);
  }
  fclose (fp_in);
  return getXML (fp_out);
}

#define ESC 27


