# include "decl.h"
# include "macros.h"
# include "fileio.h"
# include "ifunc.h"
# include <time.h>

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

	check_frz_args (1);

	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);
		mule (11);
		out (2);
		est;
		return 0;
	restart:
		sp++;
		b1 = tbel (6)->foll;
		};
	rdy (0);
	out (2);
	est;
	return 0;
	}

/*   Format : <Chr e.Expr> => e.Expr1  */
int rf_chr (void)
	{
	check_frz_args (1);

	cl;
	b1 = b1->foll;
	while (b1 != b2)
		{
		if (LINK_NUMBER (b1))
			{
		     if ( (unsigned)(b1->pair.n) > 0x7F ) {  
		        b1->ptype = LINK_TYPE_MSYMBOL;
		        utf i = r_int_to_utf(b1->pair.n);
              b1->pair.u = i;
		     } else {
		        b1->ptype = LINK_TYPE_CHAR;
			     b1->pair.c = (char)(b1->pair.n);
		     }
			}
		b1 = b1->foll;
		};
	rdy (0);
	tple (4);
	out (2);
	est;
	return 0;
	}

/*   Format : <Ord e.Expr> => e.Expr1  */
int rf_ord (void)
	{

	check_frz_args (1);

	cl;
	b1 = b1->foll;
	while (b1 != b2)
		{
		if (LINK_CHAR (b1))
			{
			b1->ptype = LINK_TYPE_NUMBER;
			b1->pair.n = b1->pair.c;
			}
		else if (LINK_MSYMBOL (b1))
			{
			b1->ptype = LINK_TYPE_NUMBER;
         b1->pair.n = ri_utf_to_int(b1->pair.u);
			};
		b1 = b1->foll;
		};
	rdy (0);
	tple (4);
	out (2);
	est;
	return 0;
	}

/*   Format : <Last s.N e.Expr> => (e.Expr1) e.Expr2 */
int rf_last ()
	{
	long k;

	movb1;
	if (LINK_VAR (b1) || GPAR (b1)) goto call_freeze;
	else if (!LINK_NUMBER (b1)) goto restart;
	k = b1->pair.n;
        if( b1 != b2 ) b1 = b1->foll;

	while ( (k-- > ((REFLONG)0L)) )
		{
		if (LINK_EVAR (b2) || EPAR (b2)) goto call_freeze;
		if (LINK_RSTRUCTB (b2) || LINK_MRSTRUCTB (b2)) b2 = b2->pair.b;
                if ( b1 == b2 ) break;
		b2 = b2->prec;
		};

	if (LINK_RSTRUCTB (b2) || LINK_MRSTRUCTB (b2)) b2 = b2->pair.b;
	tbel (4) = (b1 == b2 ? NULL : b1);
	tbel (5) = b2->prec;

	if (b2 == tbel (2))
		{
		tbel (6) = NULL;
		tbel (7) = b2;
		}
	else
		{
		tbel (6) = b2; 
		tbel (7) = tbel (2)->prec;
		}

	rdy (0);
	bl;
	tple (5);
	br;
	tple (7);
	out (2);
	est;
	return 0;

	restart:
		return ri_imp ();

	call_freeze:
		return ri_frz (1);
	}

/*   Format : <First s.N e.Expr> => (e.Expr1) e.Expr2 */
int rf_first ()
	{
	long k;

	vsym;
	if (LINK_VAR (b1) || GPAR(b1)) goto call_freeze;
	else if (!LINK_NUMBER (b1)) goto restart;
	k = b1->pair.n;
	tbel (4) = (b1 = b1->foll);

	if (b1 == b2) /*** empty exspression. **/
		{
		tbel (4) = NULL;
		tbel (5) = b2->prec;
		tbel (6) = NULL;
		tbel (7) = b2->prec;
		}
	else
		{
                if ( k == ((REFLONG)0L) ) tbel (4) = NULL;
		while ((b1 != b2) && (k-- > ((REFLONG)0L)))
			{
			if (LINK_EVAR (b1) || EPAR (b1)) goto call_freeze;
			else if (LINK_LSTRUCTB (b1) || LINK_MLSTRUCTB (b1)) b1 = b1->pair.b;
			b1 = b1->foll;
			};
		tbel (5) = b1->prec;
		tbel (6) = (b1 == b2 ? NULL : b1);
		tbel (7) = b2->prec;
		};

	rdy (0);
	bl;
	tple (5);
	br;
	tple (7);
	out (2);
	est;
	return 0;

	restart:
		return ri_imp ();

	call_freeze:
		return ri_frz (1);
	}


/*   Format : <Implode e.cahrs e.Expr> => s.COMPONDSYMB-chars e.Expr */
int rf_implode (void) {
	char str [MAXWS+1];
	int i;
	char c, *pc;

	cl;
	if ((b1 = tbel (3)) == NULL) goto zero_end;
	else if (LINK_VAR (b1) || GPAR (b1)) goto call_freeze;
	else if (!LINK_CHAR (b1) || !isalpha (b1->pair.c)) goto zero_end;
	i = 0;
	while (b1 != b2) {
		if (LINK_VAR (b1) || GPAR (b1)) goto call_freeze;
		else if (!LINK_CHAR (b1)) break;
		c = b1->pair.c;
		/* convert c to upper case checking that it is a letter, digit or $,-,_	*/
		
		/* I'm not sure in needing of the condition. */
		if (i == 0) {
			if (isalpha (c)) str [i ++] = c; /*toupper (c);*/
			else break;
		} else {
			if (isalnum (c) || c == '_' || c == '$' || c == '-') str [i++] = c;
			else break;
		}

		b1 = b1->foll;
		if (i == MAXWS) break;
	}
	str [i] = '\0';
	if (b1 == b2)  tbel (3) = NULL;
	else tbel (3) = b1;
	pc = ri_cs_impl (str);
	rdy (0);
	ncs (pc);

end:

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

zero_end:

	rdy (0);
	nns (((REFLONG)0L));
	goto end;

call_freeze:

	return ri_frz (1);
}

/*   Format : <Explode s.COMPONDSYMB-chars> => e.chars */
int rf_explode ()
	{
	char *pc;

	cl;
	if ((b1 = tbel (3)) == NULL) return ri_imp ();
	else if (LINK_VAR (b1) || GPAR (b1))
		{
		return ri_frz (1);
		}
	else if (!LINK_COMPSYM (b1)) return ri_imp ();
	else if (b1->foll != b2) return ri_imp ();
	pc = b1->pair.f;
	rdy (0);
	while (*pc != 0) /* 252 line. Was *pc != NULL. Shura. 27.01.98 */
		{
		ns (*pc);
		pc ++;
		};
	out (2);
	est;
	return 0;
	}


/*   Format : <Lower e.Expr> => e.Expr_ */
int rf_lower ()
	{

	check_frz_args (1);

	cl;
	b1 = b1->foll;
	while (b1 != b2)
		{
		if (LINK_CHAR (b1)) b1->pair.c = tolower (b1->pair.c);
		else if (LINK_MSYMBOL (b1)) {
			      utf ch = ri_tolower (b1->pair.u);
		         if ( ch > 127 )  { b1->pair.u = ch; 
		         } else { 
		                TYPE(b1) = LINK_TYPE_CHAR;
		                b1->pair.c = (unsigned char)ch; 
		        };
		} 
		b1 = b1->foll;
		};
	rdy (0);
	tple (4);
	out (2);
	est;
	return 0;
	}

/*   Format : <Upper e.Expr> => e.Expr~ */
int rf_upper (void) {
	check_frz_args (1);
	cl;
	b1 = b1->foll;
	while (b1 != b2) {
		if (LINK_CHAR (b1)) b1->pair.c = toupper (b1->pair.c);
		else if (LINK_MSYMBOL (b1)) {
			      utf ch = ri_toupper (b1->pair.u);
		         if ( ch > 127 )  { b1->pair.u = ch; 
		         } else { 
		                TYPE(b1) = LINK_TYPE_CHAR;
		                b1->pair.c = (unsigned char)ch; 
		        };
		} 
		b1 = b1->foll;
	}
	rdy (0);
	tple (4);
	out (2);
	est;
	return 0;
}

/*   Format : <Step> => s.Number */
int rf_step ()
	{

	check_freeze;

	cl;
	if (tbel (3) != NULL) return ri_imp ();

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

/*   Format : <Time> => e.string */
int rf_time ()
	{
	char *s;
/* 02.06.2022, Nemytykh */
/*	char doubleblank = 0; */
   char cnt = 0;
                         // 77777, Nemytykh, 13-04-2025
# if FOR_OS_WINDOWSNT || BY_GCC_MINGW_WIN
	time_t timer; 
	/* Nemytykh 05.02.2008. Was: the second alternative for all cases.
	   But that does not work under Visual Studio 2005 compilation
	   and under Windows XP64 running.
	*/
# else
	long timer;
# endif

	check_freeze;

	cl;
	if (tbel (3) != NULL) return ri_imp ();

	rdy (0);
# ifndef IBM370
	timer = time (NULL);
	s = ctime (&timer);
# else
	s = "n/a\n";
# endif
	while (*s != '\n')
		{
		  ns (*s);
		  while ( *s == ' ' ) { s++; cnt++; }
		  if (cnt == 0) { s++; }
		  else { cnt = 0; };
		  /*		  s++; */
		};
	out (2);
	est;
	return 0;
	}


int rf_lenw ()
	/*	Lenw computes the number of terms in the Refal expression. */
	/*	Format:
			<Lenw e.x> ==>  s.n e.x
	*/

	{
	long k;

	cl;
	k = (REFLONG) 0L;
	b1 = b1->foll;
	while (b1 != b2)
		{
		k++;
		if (LINK_LSTRUCTB (b1) || LINK_MLSTRUCTB (b1)) b1 = b1->pair.b;
		else if (LINK_EVAR (b1) || EPAR (b1))
			{
			return ri_frz (1);
			}
		b1 = b1->foll;
		};
	rdy (0);
	nns (k);
	tple (4);
	out (2);
	est;
	return 0;
	}


/*   Format : <Dgall> => (e.Name'=' e.Value)* */
int rf_dgall ()
	{

	check_freeze;

	if (b1->foll != b2) return ri_imp ();
	b1 = stock;
	b2 = stock->pair.b;
	cl;
	rdy (0);
	tple (4);
	out (2);
	est;
	return 0;
	}


/*   Format : <Rp e.Name'=' e.Expr> => e.empty */
int rf_rp ()
	/* RP: replace the argument in the stock.	*/
	{
	LINK *end;

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

	while (!LINK_CHAR (b1) || (b1->pair.c != '='))
		{
		b1 = b1->foll;
		if (b1 == b2) return ri_imp ();
		};

	/* b1 now points to the first '=' in the argument. */

	tbel (4) = b1->prec;
	if (tbel (4) ==  tbel (1)) tbel (3) = NULL;
	else tbel (3) = tbel (1)->foll;

		/* tbel (3) - (4) contain the expression before '='. */

	nel = 15;
	cl;
		/* tbel (15) - (16) contain the expression after '='. */

	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;

			/* set b to '=', transplant the new expression and
				delete the old expression */
		b = tbel (9);
		tple (16);
      if (tbel(10) != NULL) /* Nemytykh A.P., 15.05.2004 */
		        out (11);
		rdy (0);
		out (2);
		est;
		return 0;

 restart:
		sp++;
		b1 = tbel (6)->foll;
		};
	b = stock;
	rend = b->foll;
	bl;
	tple (4);
	ns ('=');
	tple (16);
	br;
	weld (b,rend);
	rdy (0);
	out (2);
	est;
	return 0;
	}

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


/*   Format : <Open s.Mode s.D e.File-name> => e.empty */
int rf_open ()
	{
	char s [FILENAME_MAX+1];
	char * p;
	char m[2];
   char * mode = m;
	int i, lognum = 0;

	check_freeze;

	b1 = b1->foll;	/* Get the mode.*/
	if (LINK_CHAR (b1)) 
           { m [0] = b1->pair.c; 
             m [1] = '\0';
           }
	else if (LINK_COMPSYM (b1)) mode = b1->pair.f;
	else return ri_imp ();

	b1 = b1->foll;	/* Get the file number. */
	if (!LINK_NUMBER (b1)) ri_imp ();
	else lognum = b1->pair.n;
	lognum %= FILE_LIMIT;
/* [ Nemytykh, 24-02-2023	*/
   get_file_name;
/* ] Nemytykh, 24-02-2023	*/
	if (i) s[i] = '\0';
	else sprintf (s,"REFAL%d.DAT",lognum);
	ri_open (lognum,mode,s);
	rdy (0);
	out (2);
	est;
	return 0;
	}

/*   Format : <GetEncBom e.File-name> => e.full-utf-enc-name | Unknown
   , where e.full-enc-name ::= 'utf-8', 'utf-16le', 'utf-16be', 'utf-32le', 'utf-32be'
*/
int rf_GetEncBom () {
	char s [FILENAME_MAX+1];
	char * p;
	int i;

	check_freeze;
   get_file_name;  // The 'i', p, s are used inside this macros.
	s[i] = '\0';
   
   FILE * fp = r_wfopen(s,"rt");
	if ( fp == NULL ) {
		fprintf(stderr,"can\'t open %s.\n",s);
      ri_error(2);
 	} else {
   	rdy (0);
		if ( r_utf_BOM(fp, ENC_BOM) == -1 ) {
		   ri_cs("Unknown");
		}
 	}
 	fclose(fp);
	out (2);
	est;
	return 0;
}

// In order to overcome an error in the MinGW preprocessor:
void ns2 (char ch) {
	ns (ch);
	return;
}
