nilopaim
/
tinycobol
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
tinycobol/lib/intrinsic.c

1474 lines
41 KiB
C
Raw Permalink Blame History

//
// Copyright (C) 2005, Walter Garrote,
// 2002, Ferran Pegueroles,
//
// This library is free software; you can redistribute it and/or
// modify it under the terms of the GNU Lesser General Public License
// as published by the Free Software Foundation; either version 2.1,
// or (at your option) any later version.
//
// This library is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
// GNU Lesser General Public License for more details.
//
// You should have received a copy of the GNU Lesser General Public
// License along with this library; see the file COPYING.LIB. If
// not, write to the Free Software Foundation, Inc., 59 Temple Place,
// Suite 330, Boston, MA 02111-1307 USA
//
// Cobol Compiler Run Time Library -- Intrinsic functions
//
//
#include "htcoblib.h"
#include "rterrors.h"
#include <stdarg.h>
#ifdef __MINGW32__
#include <process.h>
#endif
extern int bDecimalComma;
extern char cCurrencySymbol;
#define NOT_IMPLEMENTED(x) tcob_rt_error(x,TCERR_NOT_IMPLEMENTED)
#define decimal_char() (bDecimalComma?',':'.')
#define MAX_ARG_NUMBER 100
unsigned int integer_of_date(unsigned int date);
//
//
// Format for the intrinsic functions :
//
// MOVE FUNCTION <NAME> ( <ARGUMENT-1> [,<ARGUMENT-2>,...]) TO <DEST>.
// or
// MOVE FUNCTION <NAME> TO <DEST>.
//
// void tcob_intrinsic_<name>( struct fld_desc *dest_desc, char *dest_data,...)
// [ struct fld_desc *arg_desc, char *arg_data,... ]
//
//
// All the functions accept a variable number of arguments, but only use the asguments
// they need.
// The first 2 arguments are the only required anr are the destination field.
// The caller must push a NULL after last argument, so functions can
// now how many arguments are passed.
//
//
//
// Util function to convert any numeric field to an integer (similar to tcob_fldtod)
//
void fldtoint(struct fld_desc *desc, char *data,int *res){
int *num;
char pic[5];
struct fld_desc int_desc = {
4, //len
DTYPE_BININT, //type
0, // decimals
0, //pscale
0,0,0,0,0,0, //flags
NULL //PIC
};
tcob_picCreate(pic,5,'S',1,'9',9,NULL);
int_desc.pic=pic;
if (desc->type == DTYPE_BININT) {
num = (int *)data;
*res=*num;
return ;
}
tcob_move(desc,data,&int_desc,(char *)res);
}
//{"ABS",ITYPE_FLOAT,1},
void tcob_intrinsic_abs(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("ABS",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&num);
tcob_dtofld(dest_desc,dest_data,0,fabs(num));
}
//{"ACOS",ITYPE_FLOAT,1},
void tcob_intrinsic_acos(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("ACOS",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&num);
tcob_dtofld(dest_desc,dest_data,0,cos(num));
}
//{"ANNUITY",ITYPE_FLOAT,2},
void tcob_intrinsic_annuity(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm1_desc,*parm2_desc;
char *parm1_data,*parm2_data;
double num1,num2,res;
va_start(ap,dest_data);
parm1_desc = va_arg(ap,struct fld_desc *);
parm1_data = va_arg(ap,char *);
parm2_desc = va_arg(ap,struct fld_desc *);
parm2_data = va_arg(ap,char *);
va_end(ap);
if ((parm1_desc == NULL) || (parm1_data == NULL) ||
(parm2_desc == NULL) || (parm2_data == NULL)) {
tcob_rt_error("ANNUITY",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm1_desc,parm1_data,&num1);
tcob_fldtod(parm2_desc,parm2_data,&num2);
if (num1 == 0) {
res = 1/num2;
}else{
res = (num1 / (1 - pow((1 - num1),-num2)));
}
tcob_dtofld(dest_desc,dest_data,0,res);
}
//{"ASIN",ITYPE_FLOAT,1},
void tcob_intrinsic_asin(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("ASIN",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&num);
tcob_dtofld(dest_desc,dest_data,0,asin(num));
}
//{"ATAN",ITYPE_FLOAT,1},
void tcob_intrinsic_atan(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("ATAN",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&num);
tcob_dtofld(dest_desc,dest_data,0,atan(num));
}
//{"CHAR",ITYPE_ALPHA,1}, // inline
//{"COS",ITYPE_FLOAT,1},
void tcob_intrinsic_cos(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("COS",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&num);
tcob_dtofld(dest_desc,dest_data,0,cos(num));
}
//{"CURRENT-DATE",ITYPE_DATETIME,0},
void tcob_intrinsic_current_date(struct fld_desc *dest_desc, char *dest_data, ...) {
time_t now;
char now_str[22];
now = time(NULL);
// Needs fix to full positions 15 to 21 (miliseconds and dif between local and Univeral Time)
strftime(now_str,22,"%Y%m%d%H%M%S0000000",localtime(&now));
memmove(dest_data,now_str,dest_desc->len);
}
// return the month and date of giving days in year
unsigned int mmdd(int yy, int days) {
int dd, mm;
if(days == 0)
return(1231);
mm = 0;
dd = days;
do {
dd = days;
mm++;
switch(mm) {
case 1:
case 3:
case 5:
case 7:
case 8:
case 10:
case 12: days -= 31; break;
case 2: days -= 28;
if(((yy % 4) ==0 && (yy % 100) !=0) || (yy % 400) == 0)
days--;
break;
case 4:
case 6:
case 9:
case 11: days -= 30; break;
}
} while(days > 0);
return((mm * 100) + dd);
}
//{"DATE-OF-INTEGER",ITYPE_DATE,1},
void tcob_intrinsic_date_of_integer(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data, date_str[9];
int days;
struct tm date_tm;
time_t time;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("DATE-OF-INTEGER",TCERR_INTRINSIC_BAD_ARG);
}
fldtoint(parm_desc,parm_data,&days);
// walter
int yy, r1, r2, r3, r4, dayt;
unsigned int aux;
days += 584388;
r1 = days % 146097;
r2 = r1 % 36524;
r3 = r2 % 1461;
r4 = r3 % 365;
yy = ((days / 146097) * 400) + ((r1 / 36524 )* 100) + ((r2 / 1461) * 4) + (r3 / 365) + 1;
memset(date_str, 9, 0);
if(r4 == 0) // last day, subtract 1 from year
yy--;
if(r4 == 1 && r3 == 1) { // first day, force to January 1
sprintf(date_str,"%8i",(yy * 10000) + 101);
} else {
if(r4 == 0) { // whats the last day ?
aux = (yy * 10000) + 1231;
dayt = integer_of_date(aux) + 584388;
if(dayt == days || r1 == 0)
sprintf(date_str,"%8i",(yy * 10000) + 1231);
else
sprintf(date_str,"%8i",(yy * 10000) + 1230);
} else
sprintf(date_str,"%8i",(yy * 10000) + mmdd(yy, r4));
}
memmove(dest_data,date_str,dest_desc->len);
return;
//
// Set the origin of time according to cobol standard
// 31 Dec 1600
date_tm.tm_sec=0; /* seconds */
date_tm.tm_min=0; /* minutes */
date_tm.tm_hour=0; /* hours */
date_tm.tm_mday=31; /* day of the month */
date_tm.tm_mon=11; /* month 0 - 11 */
//date_tm.tm_year= -300; /* year */ /* the year 1600 */
// -300 and 0 doesn't work, and by nou we use 1901 instead
// of 1600, needs fix
date_tm.tm_year=1; /* year */
date_tm.tm_wday=0; /* day of the week */
date_tm.tm_yday=0; /* day in the year */
date_tm.tm_isdst=0; /* daylight saving time */
// Add the number of days indicated
date_tm.tm_mday += days;
time = mktime(&date_tm);
strftime(date_str,9,"%Y%m%d",localtime(&time));
memmove(dest_data,date_str,dest_desc->len);
}
//{"DATE-TO-YYYYMMDD",ITYPE_DATE,1},
/*
Needs to get and use an optinal 3rd argument (described on 2002 standard)
*/
void tcob_intrinsic_date_to_yyyymmdd(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm1_desc,*parm2_desc;
char *parm1_data, *parm2_data;
double date,limit=500000;
va_start(ap,dest_data);
parm1_desc = va_arg(ap,struct fld_desc *);
parm1_data = va_arg(ap,char *);
parm2_desc = va_arg(ap,struct fld_desc *);
parm2_data = va_arg(ap,char *);
va_end(ap);
if ((parm1_desc == NULL) || (parm1_data == NULL)) {
tcob_rt_error("DATE-TO-YYYYMMDD",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm1_desc,parm1_data,&date);
if ((parm2_desc != NULL) && (parm2_data != NULL)) {
tcob_fldtod(parm2_desc,parm2_data,&limit);
limit *= 10000;
}
if (date > limit)
date += 20000000;
else
date += 19000000;
tcob_dtofld(dest_desc,dest_data,0,date);
}
//{"DAY-OF-INTEGER",ITYPE_JULIANDATE,1},
void tcob_intrinsic_day_of_integer(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data, day_str[8];
int days;
struct tm date_tm;
time_t time;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("DAY-OF-INTEGER",TCERR_INTRINSIC_BAD_ARG);
}
fldtoint(parm_desc,parm_data,&days);
// Set the origin of time according to cobol standard
// 31 Dec 1600
date_tm.tm_sec=0; /* seconds */
date_tm.tm_min=0; /* minutes */
date_tm.tm_hour=0; /* hours */
date_tm.tm_mday=31; /* day of the month */
date_tm.tm_mon=11; /* month 0 - 11 */
//date_tm.tm_year= -300; /* year */ /* the year 1600 */
// -300 and 0 doesn't work, and by nou we use 1901 instead
// of 1600, needs fix
date_tm.tm_year=1; /* year */
date_tm.tm_wday=0; /* day of the week */
date_tm.tm_yday=0; /* day in the year */
date_tm.tm_isdst=0; /* daylight saving time */
// Add the number of days indicated
date_tm.tm_mday += days;
time = mktime(&date_tm);
strftime(day_str,8,"%Y%j",localtime(&time));
memmove(dest_data,day_str,dest_desc->len);
}
//{"DAY-TO-YYYYDDD",ITYPE_JULIANDATE,1},
/*
Needs to get and use an optinal 3rd argument (described on 2002 standard)
*/
void tcob_intrinsic_day_to_yyyyddd(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm1_desc,*parm2_desc;
char *parm1_data, *parm2_data;
double date,limit=50000;
va_start(ap,dest_data);
parm1_desc = va_arg(ap,struct fld_desc *);
parm1_data = va_arg(ap,char *);
parm2_desc = va_arg(ap,struct fld_desc *);
parm2_data = va_arg(ap,char *);
va_end(ap);
if ((parm1_desc == NULL) || (parm1_data == NULL)) {
tcob_rt_error("DAY-TO-YYYYDDD",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm1_desc,parm1_data,&date);
if ((parm2_desc != NULL) && (parm2_data != NULL)) {
tcob_fldtod(parm2_desc,parm2_data,&limit);
limit *= 1000;
}
if (date > limit)
date += 2000000;
else
date += 1900000;
tcob_dtofld(dest_desc,dest_data,0,date);
}
//{"FACTORIAL",ITYPE_INT,1},
static int fact(int num) {
if (num < 2) return 1;
else return ( fact(num - 1) * num );
}
void tcob_intrinsic_factorial(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
int num,*dest;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("FACTORIAL",TCERR_INTRINSIC_BAD_ARG);
}
dest = (int *)dest_data;
fldtoint(parm_desc,parm_data,&num);
*dest = fact(num);
}
//{"INTEGER",ITYPE_INT,1},
void tcob_intrinsic_integer(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
int num,*dest;
double parm;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("INTEGER",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&parm);
fldtoint(parm_desc,parm_data,&num);
// greatest Integer not greater than parm
if (num > parm) num = num - 1;
dest= (int *)dest_data;
*dest=num;
}
// return the days in giving year
unsigned int days_in_year(unsigned int date) {
int days_in_year, yy, mm, dd;
yy = (date / 10000);
mm = (date - (yy * 10000)) / 100;
dd = date % 100;
days_in_year = 0;
while(--mm) {
switch(mm) {
case 1:
case 3:
case 5:
case 7:
case 8:
case 10:
case 12: days_in_year += 31; break;
case 2: days_in_year += 28;
if(((yy % 4) ==0 && (yy % 100) !=0) || (yy % 400) == 0)
days_in_year++;
break;
case 4:
case 6:
case 9:
case 11: days_in_year += 30; break;
}
}
days_in_year += dd;
return(days_in_year);
}
// return the number of days after 16010101
unsigned int integer_of_date(unsigned int date) {
int year, cc, yy;
unsigned int days;
year = date / 10000;
cc = year / 100;
yy = year % 100;
days = days_in_year(date) + ((year - 1) * 365) + (cc * 24) + (cc / 4) + ((yy - 1) / 4) - 584388;
return(days);
}
//{"INTEGER-OF-DATE",ITYPE_INT,1},
void tcob_intrinsic_integer_of_date(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
struct tm date_tm,orig;
int date,day,month,year,*dest;
double secs;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("INTEGER-OF-DATE",TCERR_INTRINSIC_BAD_ARG);
}
fldtoint(parm_desc,parm_data,&date);
// date : yyyymmdd
// walter
dest=(int *)dest_data;
*dest = integer_of_date(date);
return;
//
day=date % 100;
month=(date / 100) % 100;
year=date / 10000;
// Set the origin of time according to cobol standard
// 31 Dec 1600
orig.tm_sec=0; /* seconds */
orig.tm_min=0; /* minutes */
orig.tm_hour=0; /* hours */
orig.tm_mday=31; /* day of the month */
orig.tm_mon=11; /* month 0 - 11 */
//date_tm.tm_year= -300; /* year */ /* the year 1600 */
// -300 and 0 doesn't work, and by nou we use 1901 instead
// of 1600, needs fix
orig.tm_year=1; /* year 0 = 1900*/
orig.tm_wday=0; /* day of the week */
orig.tm_yday=0; /* day in the year */
orig.tm_isdst=0; /* daylight saving time */
date_tm.tm_sec=0; /* seconds */
date_tm.tm_min=0; /* minutes */
date_tm.tm_hour=0; /* hours */
date_tm.tm_mday=day; /* day of the month */
date_tm.tm_mon=month - 1; /* month 0 - 11 */
date_tm.tm_year=year - 1900; /* year 0 = 1900*/
date_tm.tm_wday=0; /* day of the week */
date_tm.tm_yday=0; /* day in the year */
date_tm.tm_isdst=0; /* daylight saving time */
// Add the number of days indicated
secs = difftime(mktime(&date_tm),mktime(&orig));
dest=(int *)dest_data;
*dest=(int) (secs / (60 * 60 * 24)) + 1;
}
//{"INTEGER-OF-DAY",ITYPE_INT,1},
void tcob_intrinsic_integer_of_day(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
struct tm date_tm,orig;
int date,day,year,*dest;
double secs;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("INTEGER-OF-DAY",TCERR_INTRINSIC_BAD_ARG);
}
fldtoint(parm_desc,parm_data,&date);
// date : yyyyddd
day=date % 1000;
year=date / 1000;
// Set the origin of time according to cobol standard
// 31 Dec 1600
orig.tm_sec=0; /* seconds */
orig.tm_min=0; /* minutes */
orig.tm_hour=0; /* hours */
orig.tm_mday=31; /* day of the month */
orig.tm_mon=11; /* month 0 - 11 */
//date_tm.tm_year= -300; /* year */ /* the year 1600 */
// -300 and 0 doesn't work, and by nou we use 1901 instead
// of 1600, needs fix
orig.tm_year=1; /* year 0 = 1900*/
orig.tm_wday=0; /* day of the week */
orig.tm_yday=0; /* day in the year */
orig.tm_isdst=0; /* daylight saving time */
date_tm.tm_sec=0; /* seconds */
date_tm.tm_min=0; /* minutes */
date_tm.tm_hour=0; /* hours */
date_tm.tm_mday=day; /* day of the month */
date_tm.tm_mon=0; /* month 0 - 11 */
date_tm.tm_year=year - 1900; /* year 0 = 1900*/
date_tm.tm_wday=0; /* day of the week */
date_tm.tm_yday=0; /* day in the year */
date_tm.tm_isdst=0; /* daylight saving time */
// Add the number of days indicated
//fprintf(stderr,"%s\n",ctime(mktime(&orig)));
secs = difftime(mktime(&date_tm),mktime(&orig));
dest=(int *)dest_data;
*dest=(int) (secs / (60 * 60 * 24)) + 1;
}
//{"INTEGER-PART",ITYPE_INT,1},
void tcob_intrinsic_integer_part(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
int num,*dest;
double parm;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("INTEGER-PART",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&parm);
fldtoint(parm_desc,parm_data,&num);
// greatest Integer not greater than parm
if (num > 0){
if ( num > parm) num--;
} else {
if ( num < parm) num++;
}
dest= (int *)dest_data;
*dest=num;
}
//{"LENGTH",ITYPE_INT,1}, // inline
//{"LOG",ITYPE_FLOAT,1},
void tcob_intrinsic_log(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("LOG",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&num);
tcob_dtofld(dest_desc,dest_data,0,log(num));
}
//{"LOG10",ITYPE_FLOAT,1},
void tcob_intrinsic_log10(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("LOG10",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&num);
tcob_dtofld(dest_desc,dest_data,0,log10(num));
}
//{"LOWER-CASE",ITYPE_ALPHA,1},
void tcob_intrinsic_lower_case(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
int i,max_len;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("LOWER-CASE",TCERR_INTRINSIC_BAD_ARG);
}
if ((parm_desc->type != DTYPE_ALPHANUMERIC) &&
(parm_desc->type != DTYPE_ALPHA) &&
(parm_desc->type != DTYPE_GROUP)) {
tcob_rt_error("LOWER-CASE",TCERR_INTRINSIC_BAD_ARG);
}
max_len = tc_min(parm_desc->len,dest_desc->len);
for(i=0;i < max_len;i++){
dest_data[i]=tolower(parm_data[i]);
}
}
//{"MAX",ITYPE_FLOAT,ANY_NUMBER},
void tcob_intrinsic_max(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num,max;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // At leas one argumetn is required
tcob_rt_error("MAX",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&max); // move the first number to the maximum
while((parm_desc !=NULL) && (parm_data !=NULL)){
tcob_fldtod(parm_desc,parm_data,&num);
if (num > max) max=num;
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
}
va_end(ap);
tcob_dtofld(dest_desc,dest_data,0,max);
}
//{"MEAN",ITYPE_FLOAT,ANY_NUMBER},
void tcob_intrinsic_mean(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num,mean;
int count;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // At leas one argumetn is required
tcob_rt_error("MEAN",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&mean); // move the first number to the mean
count = 1;
while((parm_desc !=NULL) && (parm_data !=NULL)){
tcob_fldtod(parm_desc,parm_data,&num);
mean = mean + num;
count++;
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
}
mean = mean / count;
va_end(ap);
tcob_dtofld(dest_desc,dest_data,0,mean);
}
//{"MEDIAN",ITYPE_FLOAT,ANY_NUMBER},
struct double_list {
struct double_list *next;
double num;
};
void tcob_intrinsic_median(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num;
struct double_list *list;
struct double_list *item;
struct double_list *new_item;
int count,i;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // At leas one argumetn is required
tcob_rt_error("MEDIAN",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&num); // move the first number
list=tcob_rt_malloc("MEDIAN",sizeof(struct double_list));
list->next = NULL;
list->num = num;
count = 1;
while((parm_desc !=NULL) && (parm_data !=NULL)){ //create an ordered list
tcob_fldtod(parm_desc,parm_data,&num);
for(item=list;item->next!=NULL;item=item->next)
{
if (item->num > num){
new_item=tcob_rt_malloc("MEDIAN",sizeof(struct double_list));
new_item->next = item->next;
new_item->num = num;
item->next = new_item;
break;
}
}
count++;
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
}
// find the element in the middle of list
for(i=0,item=list;i< count/2;i++,item=item->next) ;
num = item->num;
va_end(ap);
tcob_dtofld(dest_desc,dest_data,0,num);
}
//{"MIDRANGE",ITYPE_FLOAT,ANY_NUMBER},
void tcob_intrinsic_midrange(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num,min,max;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // At leas one argumetn is required
tcob_rt_error("MIDRANGE",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&min); // move the first number to the minimum
max = min; // and to the maximum
while((parm_desc !=NULL) && (parm_data !=NULL)){
tcob_fldtod(parm_desc,parm_data,&num);
if (num < min) min=num;
if (num > max) max=num;
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
}
va_end(ap);
num = (max - min) / 2;
tcob_dtofld(dest_desc,dest_data,0,num);
}
//{"MIN",ITYPE_FLOAT,ANY_NUMBER},
void tcob_intrinsic_min(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num,min;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // At leas one argumetn is required
tcob_rt_error("MIN",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&min); // move the first number to the minimum
while((parm_desc !=NULL) && (parm_data !=NULL)){
tcob_fldtod(parm_desc,parm_data,&num);
if (num < min) min=num;
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
}
va_end(ap);
tcob_dtofld(dest_desc,dest_data,0,min);
}
//{"MOD",ITYPE_INT,2},
void tcob_intrinsic_mod(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
int int1,int2;
int *mod;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // Argument 1
tcob_rt_error("MOD",TCERR_INTRINSIC_BAD_ARG);
}
fldtoint(parm_desc,parm_data,&int1);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // Argument 2
tcob_rt_error("MOD",TCERR_INTRINSIC_BAD_ARG);
}
fldtoint(parm_desc,parm_data,&int2);
va_end(ap);
mod=(int *)dest_data;
*mod=int1%int2;
}
/*
* Parses the string and returns the number that the string represents.
* Is currency = 1, the string can ccontain currency simbols.
*
*/
static double parse_numval(char *str,int currency){
char *p;
char digits[50];
int num_digits=0,sign=0;
double num;
p=str;
while(isspace((int)*p)) p++;
if (currency) {
if (*p == cCurrencySymbol) {
p++;
while(isspace((int)*p)) p++;
}
}
if (*p=='+') { sign = +1; p++; }
else if (*p=='-') { sign = -1; p++; }
while(isspace((int)*p)) p++;
while(isdigit((int)*p)){
digits[num_digits]=*p;
num_digits++;
p++;
}
if (*p == decimal_char()){
digits[num_digits]='.';
num_digits++;
p++;
}
while(isdigit((int)*p)){
digits[num_digits]=*p;
num_digits++;
p++;
}
while(isspace((int)*p)) p++;
if (*p=='+') { sign = +1; p++; }
else if (*p=='-') { sign = -1; p++; }
else if ( strncasecmp(p,"CR",2) == 0) { sign = -1; p+=2; }
else if ( strncasecmp(p,"DB",2) == 0) { sign = -1; p+=2; }
if (currency) {
if (*p == cCurrencySymbol) {
p++;
while(isspace((int)*p)) p++;
}
}
digits[num_digits]='\0';
num = atof(digits);
if (sign < 0)
num = num * -1 ;
return num;
}
//{"NUMVAL",ITYPE_FLOAT,1},
void tcob_intrinsic_numval(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
char *str;
double num;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // Argument 1
tcob_rt_error("NUMVAL",TCERR_INTRINSIC_BAD_ARG);
}
va_end(ap);
str = tcob_rt_malloc("NUMVAL",parm_desc->len + 1);
memmove(str,parm_data,parm_desc->len);
str[parm_desc->len]='\0';
num = parse_numval(str,0);
free(str);
//fprintf(stderr,"str:<%s>digits<%s>n:<%f>\n",str,digits,num);
tcob_dtofld(dest_desc,dest_data,0,num);
}
//{"NUMVAL-C",ITYPE_FLOAT,ANY_NUMBER},
void tcob_intrinsic_numval_c(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
char *str;
double num;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // Argument 1
tcob_rt_error("NUMVAL-C",TCERR_INTRINSIC_BAD_ARG);
}
va_end(ap);
str = tcob_rt_malloc("NUMVAL-C",parm_desc->len + 1);
if (str == NULL ){
//report error
}
memmove(str,parm_data,parm_desc->len);
str[parm_desc->len]='\0';
num = parse_numval(str,1);
free(str);
//fprintf(stderr,"str:<%s>digits<%s>n:<%f>\n",str,digits,num);
tcob_dtofld(dest_desc,dest_data,0,num);
}
//{"ORD",ITYPE_INT,1}, // inline
//{"ORD-MAX",ITYPE_INT,ANY_NUMBER},
void tcob_intrinsic_ord_max(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num,max;
int *ord_max,count;
ord_max=(int *)dest_data;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // At leas one argumetn is required
tcob_rt_error("ORD-MAX",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&max); // move the first number to the maximum
count = 1;
*ord_max = 1;
while((parm_desc !=NULL) && (parm_data !=NULL)){
tcob_fldtod(parm_desc,parm_data,&num);
count++;
if (num > max) { max=num; *ord_max=count;}
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
}
va_end(ap);
}
//{"ORD-MIN",ITYPE_INT,ANY_NUMBER},
void tcob_intrinsic_ord_min(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num,min;
int *ord_min,count;
ord_min=(int *)dest_data;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // At leas one argumetn is required
tcob_rt_error("ORD-MIN",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&min); // move the first number to the minimum
count = 1;
*ord_min = 1;
while((parm_desc !=NULL) && (parm_data !=NULL)){
tcob_fldtod(parm_desc,parm_data,&num);
count++;
if (num < min) { min=num; *ord_min=count;}
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
}
va_end(ap);
}
//{"PRESENT-VALUE",ITYPE_FLOAT,ANY_NUMBER},
void tcob_intrinsic_present_value(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double args[MAX_ARG_NUMBER];
double res;
int count,i;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // At leas two arguments are required
tcob_rt_error("PRESENT-VALUE",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&args[0]); // move the first number
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
count = 1;
while((parm_desc !=NULL) && (parm_data !=NULL)){
tcob_fldtod(parm_desc,parm_data,&args[count]);
count++;
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
}
va_end(ap);
if (count < 2) { // At leas two arguments are required
tcob_rt_error("PRESENT-VALUE",TCERR_INTRINSIC_BAD_ARG);
}
for(i = 1;i< count;i++) {
res = res + ( args[i] / pow( 1 + args[0],i));
}
tcob_dtofld(dest_desc,dest_data,0,res);
}
//{"RANDOM",ITYPE_FLOAT,1},
void tcob_intrinsic_random(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
int seed;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc != NULL) && (parm_data != NULL)) { // If an argument is speciufied is the seed
fldtoint(parm_desc,parm_data,&seed); // move the seed
srand(seed);
}
tcob_dtofld(dest_desc,dest_data,0,rand());
}
//{"RANGE",ITYPE_FLOAT,ANY_NUMBER},
void tcob_intrinsic_range(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double min,max,num;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // At leas one argumetn is required
tcob_rt_error("RANGE",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&min); // move the first number to the minimum
max = min; // and to the maximum
while((parm_desc !=NULL) && (parm_data !=NULL)){
tcob_fldtod(parm_desc,parm_data,&num);
if (num < min) min=num;
if (num > max) max=num;
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
}
va_end(ap);
tcob_dtofld(dest_desc,dest_data,0,(max - min));
}
//{"REM",ITYPE_INT,2},
void tcob_intrinsic_rem(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
int int1,int2;//,div;
int *res;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // 2 arguments required
tcob_rt_error("REM",TCERR_INTRINSIC_BAD_ARG);
}
fldtoint(parm_desc,parm_data,&int1);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // 2 arguments required
tcob_rt_error("REM",TCERR_INTRINSIC_BAD_ARG);
}
fldtoint(parm_desc,parm_data,&int2);
va_end(ap);
res=(int *)dest_data;
// walter
*res = int1 % int2;
// div = int1 / int2;
// *res=int1 - int2*div;
}
//{"REVERSE",ITYPE_ALPHA,1},
void tcob_intrinsic_reverse(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
int i,max_len;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("REVERSE",TCERR_INTRINSIC_BAD_ARG);
}
if ((parm_desc->type != DTYPE_ALPHANUMERIC) &&
(parm_desc->type != DTYPE_ALPHA) &&
(parm_desc->type != DTYPE_GROUP)) {
tcob_rt_error("REVERSE",TCERR_INTRINSIC_BAD_ARG);
}
max_len = tc_min(parm_desc->len,dest_desc->len);
for(i=0;i < max_len;i++){
dest_data[i]=parm_data[parm_desc->len - i];
}
}
//{"SIN",ITYPE_FLOAT,1},
void tcob_intrinsic_sin(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("SIN",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&num);
tcob_dtofld(dest_desc,dest_data,0,sin(num));
}
//{"SQRT",ITYPE_FLOAT,1},
void tcob_intrinsic_sqrt(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("SQRT",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&num);
tcob_dtofld(dest_desc,dest_data,0,sqrt(num));
}
//{"STANDARD-DEVIATION",ITYPE_FLOAT,ANY_NUMBER},
void tcob_intrinsic_standard_deviation(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double args[MAX_ARG_NUMBER];
double mean;
double res;
int i,count;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // At leas one argumetn is required
tcob_rt_error("STANDARD-DEVIATION",TCERR_INTRINSIC_BAD_ARG);
}
count=1;
tcob_fldtod(parm_desc,parm_data,&args[0]); // move the first number
while((parm_desc !=NULL) && (parm_data !=NULL)){
tcob_fldtod(parm_desc,parm_data,&args[count]);
count ++;
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
}
va_end(ap);
// calculate the mean;
mean=0;
for(i=0;i<count;i++){
mean=mean+args[i];
}
mean=mean/count;
res=0;
for(i=0;i<count;i++){
res=res +pow(fabs(mean - args[i]),2);
}
res=sqrt(res / count);
tcob_dtofld(dest_desc,dest_data,0,res);
}
//{"SUM",ITYPE_FLOAT,ANY_NUMBER},
void tcob_intrinsic_sum(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double res,num;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // At leas one argumetn is required
tcob_rt_error("SUM",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&res); // move the first number
while((parm_desc !=NULL) && (parm_data !=NULL)){
tcob_fldtod(parm_desc,parm_data,&num);
res+=num;
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
}
va_end(ap);
tcob_dtofld(dest_desc,dest_data,0,res);
}
//{"TAN",ITYPE_FLOAT,1},
void tcob_intrinsic_tan(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double num;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("TAN",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm_desc,parm_data,&num);
tcob_dtofld(dest_desc,dest_data,0,tan(num));
}
//{"TEST-DATE-YYYYMMDD",ITYPE_INT,1},
void tcob_intrinsic_test_date_yyyymmdd(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
int *res;
int date,day,month,year;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("TEST-DATE-YYYYMMDD",TCERR_INTRINSIC_BAD_ARG);
}
fldtoint(parm_desc,parm_data,&date);
day=date % 100;
month=(date / 100) % 100;
year=date / 10000;
res=(int *)dest_data;
if ((year < 1600) || (year > 9999)){
*res=1;
return;
}
if ((month < 1) || (month > 12)){
*res=1;
return;
}
switch(month){
case 2:
if (day > 29) {
*res=1;
return;
}
break;
case 4:
case 6:
case 9:
case 11:
if (day > 29) {
*res=1;
return;
}
break;
default:
if (day > 31) {
*res=1;
return;
}
break;
}
*res=0;
}
//{"TEST-DAY-YYYYDDD",ITYPE_INT,1},
void tcob_intrinsic_test_day_yyyyddd(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
int *res;
int date,day,year;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("TEST-DAY-YYYYDDD",TCERR_INTRINSIC_BAD_ARG);
}
fldtoint(parm_desc,parm_data,&date);
day=date % 1000;
year=date / 1000;
res=(int *)dest_data;
if ((year < 1600) || (year > 9999)){
*res=1;
return;
}
if ((day < 1) || (day > 366)){
*res=1;
return;
}
*res=0;
}
//{"UPPER-CASE",ITYPE_ALPHA,1},
void tcob_intrinsic_upper_case(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
int i,max_len;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
va_end(ap);
if ((parm_desc == NULL) || (parm_data == NULL)) {
tcob_rt_error("UPPER-CASE",TCERR_INTRINSIC_BAD_ARG);
}
if ((parm_desc->type != DTYPE_ALPHANUMERIC) &&
(parm_desc->type != DTYPE_ALPHA) &&
(parm_desc->type != DTYPE_GROUP)) {
tcob_rt_error("UPPER-CASE",TCERR_INTRINSIC_BAD_ARG);
}
max_len = tc_min(parm_desc->len,dest_desc->len);
for(i=0;i < max_len;i++){
dest_data[i]=toupper(parm_data[i]);
}
}
//{"VARIANCE",ITYPE_FLOAT,ANY_NUMBER},
void tcob_intrinsic_variance(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm_desc;
char *parm_data;
double args[MAX_ARG_NUMBER];
double mean;
double res;
int i,count;
va_start(ap,dest_data);
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
if ((parm_desc == NULL) || (parm_data == NULL)) { // At leas one argumetn is required
tcob_rt_error("VARIANCE",TCERR_INTRINSIC_BAD_ARG);
}
count=1;
tcob_fldtod(parm_desc,parm_data,&args[0]); // move the first number
while((parm_desc !=NULL) && (parm_data !=NULL)){
tcob_fldtod(parm_desc,parm_data,&args[count]);
count ++;
parm_desc = va_arg(ap,struct fld_desc *);
parm_data = va_arg(ap,char *);
}
va_end(ap);
// calculate the mean;
mean=0;
for(i=0;i<count;i++){
mean=mean+args[i];
}
mean=mean/count;
res=0;
for(i=0;i<count;i++){
res=res +pow(fabs(mean - args[i]),2);
}
res=res / count;
tcob_dtofld(dest_desc,dest_data,0,res);
}
//{"WHEN-COMPILED",ITYPE_DATETIME}, //inline
//{"YEAR-TO-YYYY",ITYPE_YEAR},
void tcob_intrinsic_year_to_yyyy(struct fld_desc *dest_desc, char *dest_data, ...) {
va_list ap;
struct fld_desc *parm1_desc,*parm2_desc;
char *parm1_data, *parm2_data;
int limit=50;
double year;
va_start(ap,dest_data);
parm1_desc = va_arg(ap,struct fld_desc *);
parm1_data = va_arg(ap,char *);
parm2_desc = va_arg(ap,struct fld_desc *);
parm2_data = va_arg(ap,char *);
va_end(ap);
if ((parm1_desc == NULL) || (parm1_data == NULL)) {
tcob_rt_error("YEAR-TO-YYYY",TCERR_INTRINSIC_BAD_ARG);
}
tcob_fldtod(parm1_desc,parm1_data,&year);
if ((parm2_desc != NULL) && (parm2_data != NULL)) {
fldtoint(parm2_desc,parm2_data,&limit);
}
if (year < 100) {
if (year > limit) {
year += 2000;
} else {
year += 1900;
}
}
tcob_dtofld(dest_desc,dest_data,0,year);
}
Reference in New Issue View Git Blame Copy Permalink