/*-------------------------------------------------------------------------
* Function: lite_PD_copy_syment
*
* Purpose: Make and return a copy of the given syment.
*
* Return: Success: a new syment
*
* Failure:
*
* Programmer: Adapted from PACT PDB
* Mar 6, 1996 11:39 AM EST
*
* Modifications:
* Eric Brugger, Tue Dec 8 15:16:07 PST 1998
* Remove unnecessary calls to lite_SC_mark, since reference count now
* set when allocated.
*
*-------------------------------------------------------------------------
*/
syment *
lite_PD_copy_syment (syment *osym) {
int i, n;
char *ntype;
syment *nsym;
symblock *nsp, *osp;
dimdes *ndims;
if (osym == NULL) return(NULL);
nsym = FMAKE(syment, "PD_COPY_SYMENT:nsym");
n = PD_n_blocks(osym);
osp = PD_entry_blocks(osym);
nsp = FMAKE_N(symblock, n, "PD_COPY_SYMENT:blocks");
for (i = 0; i < n; i++) nsp[i] = osp[i];
ntype = lite_SC_strsavef(PD_entry_type(osym),
"char*:PD_COPY_SYMENT:type");
ndims = lite_PD_copy_dims(PD_entry_dimensions(osym));
PD_entry_blocks(nsym) = nsp;
PD_entry_type(nsym) = ntype;
PD_entry_dimensions(nsym) = ndims;
PD_entry_number(nsym) = PD_entry_number(osym);
PD_entry_indirects(nsym) = PD_entry_indirects(osym);
return(nsym);
}
/*-------------------------------------------------------------------------
* Function: _lite_PD_mk_syment
*
* Purpose: Make and return a pointer to an entry for the symbol table.
*
* Return: Success:
*
* Failure:
*
* Programmer: Adapted from PACT PDB
* Mar 5, 1996 2:16 PM EST
*
* Modifications:
* Eric Brugger, Tue Dec 8 15:16:07 PST 1998
* Remove unnecessary calls to lite_SC_mark, since reference count now
* set when allocated.
*
*-------------------------------------------------------------------------
*/
syment *
_lite_PD_mk_syment (char *type, long numb, long addr,
symindir *indr, dimdes *dims) {
syment *ep;
symblock *sp;
char *t;
ep = FMAKE(syment, "_PD_MK_SYMENT:ep");
sp = FMAKE(symblock, "_PD_MK_SYMENT:sp");
PD_entry_blocks(ep) = sp;
sp->number = numb;
sp->diskaddr = addr;
if (type == NULL) {
t = NULL;
} else {
t = lite_SC_strsavef(type, "char*:_PD_MK_SYMENT:type");
}
PD_entry_type(ep) = t;
PD_entry_number(ep) = numb;
PD_entry_dimensions(ep) = dims;
if (indr == NULL) {
symindir iloc;
iloc.addr = 0L;
iloc.n_ind_type = 0L;
iloc.arr_offs = 0L;
PD_entry_indirects(ep) = iloc;
} else {
PD_entry_indirects(ep) = *indr;
}
return(ep);
}
/*-------------------------------------------------------------------------
* Function: lite_PD_entry_number
*
* Purpose: Query entry number
*
* Programmer: Adapted from PACT, Burl Hall, 26Feb08
*
*-------------------------------------------------------------------------
*/
int lite_PD_entry_number(syment* entry) {
return (PD_entry_number(entry));
}
static syment *
_PD_write (PDBfile *file, char *name, char *intype, char *outtype,
byte *vr, dimdes *dims, int appnd) {
int reset;
syment *ep;
long number, addr;
char bf[MAXLINE], fullpath[MAXLINE], *lname;
_append_flag = FALSE;
ep = NULL;
switch (setjmp(_lite_PD_write_err)) {
case ABORT : return(NULL);
case ERR_FREE : return(ep);
default : memset(lite_PD_err, 0, MAXLINE);
break;
}
if (file->mode == PD_OPEN) {
lite_PD_error("FILE OPENED IN READ-ONLY MODE - _PD_WRITE", PD_WRITE);
}
strcpy(fullpath, _lite_PD_fixname(file, name));
/*
* Append a new block to an existing entry if TRUE.
*/
if (appnd) {
strcpy(bf, fullpath);
/*
* Do this so that things such as a[20:20].b work properly
* NOTE: this also implies that a[20:20].b.c works while
* a.b[20:20].c doesn't
* for now this defines the semantics of append (10/6/93)
*/
lname = lite_SC_firsttok(bf, ".()[]");
ep = lite_PD_inquire_entry(file, lname, FALSE, NULL);
if (ep == NULL) {
lite_PD_error("CAN'T APPEND TO NON-EXISTING ENTRY - _PD_WRITE",
PD_WRITE);
}
_lite_PD_adj_dimensions(file, fullpath, ep);
/*
* Extend the syment.
*/
_lite_PD_add_block(file, ep, dims);
}
addr = file->chrtaddr;
ep = _lite_PD_effective_ep(file, fullpath, FALSE, NULL);
if (ep != NULL) {
/*
* If the variable already exists use the existing file info.
*/
addr = PD_entry_address(ep);
_lite_PD_rl_dimensions(dims);
#if 0
number = PD_entry_number(ep);
#endif
lname = fullpath;
reset = FALSE;
} else {
/*
* If the variable doesn't exist define it to the file.
*/
number = _lite_PD_comp_num(dims);
ep = _lite_PD_mk_syment(outtype, number, addr, NULL, dims);
strcpy(bf, fullpath);
lname = lite_SC_firsttok(bf, ".([ ");
_lite_PD_e_install(lname, ep, file->symtab);
reset = TRUE;
}
if (file->virtual_internal) {
SC_address ad;
ad.memaddr = vr;
ep->blocks->diskaddr = ad.diskaddr;
lite_SC_mark(vr, 1);
ep = lite_PD_copy_syment(ep);
} else {
if (outtype == NULL) outtype = PD_entry_type(ep);
if (intype == NULL) intype = outtype;
/*
* Go to the correct address.
*/
if (io_seek(file->stream, addr, SEEK_SET)) {
lite_PD_error("FSEEK FAILED TO FIND CURRENT ADDRESS - _PD_WRITE",
PD_WRITE);
}
/*
* Do the low level write.
*/
if (!_lite_PD_hyper_write(file, lname, ep, vr, intype)) {
lite_PD_error("CAN'T WRITE VARIABLE - _PD_WRITE", PD_WRITE);
}
/*
* If the variable didn't previously exist we're at the end
* of the file.
*/
if (reset) {
file->chrtaddr = io_tell(file->stream);
if (file->chrtaddr == -1L) {
lite_PD_error("CAN'T FIND ADDRESS OF NEXT VARIABLE - _PD_WRITE",
PD_WRITE);
}
/*
* Make a releasable copy of the entry
* SX depends on this critically!!
*/
ep = lite_PD_copy_syment(ep);
}
}
return(ep);
}
