void wrap(QSP_ARG_DECL Data_Obj *dst_dp,Data_Obj *src_dp)
{
int status;
Vector_Function *vfp;
vfp=FIND_VEC_FUNC(FVMOV);
if( (status=old_cksiz(QSP_ARG VF_FLAGS(vfp),dst_dp,src_dp))==(-1)) return;
#ifdef CAUTIOUS
if( status!=0){
sprintf(ERROR_STRING,"CAUTIOUS: wrap: old_cksiz() error...");
WARN(ERROR_STRING);
}
#endif /* CAUTIOUS */
if( dp_same_prec(dst_dp,src_dp,"wrap") == 0 ) return;
#ifdef FOOBAR
if( cktype(dst_dp,src_dp)==(-1)) return;
#endif /* FOOBAR */
dp_scroll(QSP_ARG dst_dp,src_dp,(incr_t)(OBJ_COLS(dst_dp)/2),(incr_t)(OBJ_ROWS(dst_dp)/2));
}
setdata(register Addrp varp, register Constp valp, ftnint elen)
#endif
{
struct Constblock con;
register int type;
int i, k, valtype;
ftnint offset;
char *varname;
static Addrp badvar;
register unsigned char *s;
static int last_lineno;
static char *last_varname;
if (varp->vstg == STGCOMMON) {
if (!(dfile = blkdfile))
dfile = blkdfile = opf(blkdfname, textwrite);
}
else {
if (procclass == CLBLOCK) {
if (varp != badvar) {
badvar = varp;
warn1("%s is not in a COMMON block",
varp->uname_tag == UNAM_NAME
? varp->user.name->fvarname
: "???");
}
return;
}
if (!(dfile = initfile))
dfile = initfile = opf(initfname, textwrite);
}
varname = dataname(varp->vstg, varp->memno);
offset = varp->memoffset->constblock.Const.ci;
type = varp->vtype;
valtype = valp->vtype;
if(type!=TYCHAR && valtype==TYCHAR)
{
if(! ftn66flag
&& (last_varname != cur_varname || last_lineno != lineno)) {
/* prevent multiple warnings */
last_lineno = lineno;
warn1(
"non-character datum %.42s initialized with character string",
last_varname = cur_varname);
}
varp->vleng = ICON(typesize[type]);
varp->vtype = type = TYCHAR;
}
else if( (type==TYCHAR && valtype!=TYCHAR) ||
(cktype(OPASSIGN,type,valtype) == TYERROR) )
{
err("incompatible types in initialization");
return;
}
if(type == TYADDR)
con.Const.ci = valp->Const.ci;
else if(type != TYCHAR)
{
if(valtype == TYUNKNOWN)
con.Const.ci = valp->Const.ci;
else consconv(type, &con, valp);
}
k = 1;
switch(type)
{
case TYLOGICAL:
case TYINT1:
case TYLOGICAL1:
case TYLOGICAL2:
case TYSHORT:
case TYLONG:
#ifdef TYQUAD
case TYQUAD:
#endif
dataline(varname, offset, type);
prconi(dfile, con.Const.ci);
break;
case TYADDR:
dataline(varname, offset, type);
prcona(dfile, con.Const.ci);
break;
case TYCOMPLEX:
case TYDCOMPLEX:
k = 2;
case TYREAL:
case TYDREAL:
dataline(varname, offset, type);
prconr(dfile, &con, k);
break;
case TYCHAR:
k = valp -> vleng -> constblock.Const.ci;
if (elen < k)
k = elen;
s = (unsigned char *)valp->Const.ccp;
for(i = 0 ; i < k ; ++i) {
dataline(varname, offset++, TYCHAR);
fprintf(dfile, "\t%d\n", *s++);
}
k = elen - valp->vleng->constblock.Const.ci;
if(k > 0) {
dataline(varname, offset, TYBLANK);
fprintf(dfile, "\t%d\n", k);
}
break;
default:
badtype("setdata", type);
}
}
