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); } }