int
elfreloc1(Reloc *r, vlong sectoff)
{
int32 elfsym;
LPUT(sectoff);
elfsym = r->xsym->elfsym;
switch(r->type) {
default:
return -1;
case D_ADDR:
if(r->siz == 4)
LPUT(R_386_32 | elfsym<<8);
else
return -1;
break;
case D_PCREL:
if(r->siz == 4)
LPUT(R_386_PC32 | elfsym<<8);
else
return -1;
break;
case D_TLS:
if(r->siz == 4)
LPUT(R_386_TLS_LE | elfsym<<8);
else
return -1;
}
return 0;
}
int
machoreloc1(Reloc *r, vlong sectoff)
{
uint32 v;
LSym *rs;
rs = r->xsym;
if(rs->type == SHOSTOBJ || r->type == R_PCREL) {
if(rs->dynid < 0) {
diag("reloc %d to non-macho symbol %s type=%d", r->type, rs->name, rs->type);
return -1;
}
v = rs->dynid;
v |= 1<<27; // external relocation
} else {
v = rs->sect->extnum;
if(v == 0) {
diag("reloc %d to symbol %s in non-macho section %s type=%d", r->type, rs->name, rs->sect->name, rs->type);
return -1;
}
}
switch(r->type) {
default:
return -1;
case R_ADDR:
v |= MACHO_X86_64_RELOC_UNSIGNED<<28;
break;
case R_CALL:
v |= 1<<24; // pc-relative bit
v |= MACHO_X86_64_RELOC_BRANCH<<28;
break;
case R_PCREL:
// NOTE: Only works with 'external' relocation. Forced above.
v |= 1<<24; // pc-relative bit
v |= MACHO_X86_64_RELOC_SIGNED<<28;
}
switch(r->siz) {
default:
return -1;
case 1:
v |= 0<<25;
break;
case 2:
v |= 1<<25;
break;
case 4:
v |= 2<<25;
break;
case 8:
v |= 3<<25;
break;
}
LPUT(sectoff);
LPUT(v);
return 0;
}
int
machoreloc1(Reloc *r, vlong sectoff)
{
uint32 v;
Sym *rs;
rs = r->xsym;
if(rs->type == SHOSTOBJ) {
if(rs->dynid < 0) {
diag("reloc %d to non-macho symbol %s type=%d", r->type, rs->name, rs->type);
return -1;
}
v = rs->dynid;
v |= 1<<27; // external relocation
} else {
v = rs->sect->extnum;
if(v == 0) {
diag("reloc %d to symbol %s in non-macho section %s type=%d", r->type, rs->name, rs->sect->name, rs->type);
return -1;
}
}
switch(r->type) {
default:
return -1;
case D_ADDR:
v |= MACHO_GENERIC_RELOC_VANILLA<<28;
break;
case D_PCREL:
v |= 1<<24; // pc-relative bit
v |= MACHO_GENERIC_RELOC_VANILLA<<28;
break;
}
switch(r->siz) {
default:
return -1;
case 1:
v |= 0<<25;
break;
case 2:
v |= 1<<25;
break;
case 4:
v |= 2<<25;
break;
case 8:
v |= 3<<25;
break;
}
LPUT(sectoff);
LPUT(v);
return 0;
}
void
elf64phdr(ElfPhdr *e)
{
LPUT(e->type);
LPUT(e->flags);
VPUT(e->off);
VPUT(e->vaddr);
VPUT(e->paddr);
VPUT(e->filesz);
VPUT(e->memsz);
VPUT(e->align);
}
void
elf32phdr(ElfPhdr *e)
{
int frag;
if(e->type == PT_LOAD) {
// Correct ELF loaders will do this implicitly,
// but buggy ELF loaders like the one in some
// versions of QEMU won't.
frag = e->vaddr&(e->align-1);
e->off -= frag;
e->vaddr -= frag;
e->paddr -= frag;
e->filesz += frag;
e->memsz += frag;
}
LPUT(e->type);
LPUT(e->off);
LPUT(e->vaddr);
LPUT(e->paddr);
LPUT(e->filesz);
LPUT(e->memsz);
LPUT(e->flags);
LPUT(e->align);
}
void
elf32shdr(ElfShdr *e)
{
LPUT(e->name);
LPUT(e->type);
LPUT(e->flags);
LPUT(e->addr);
LPUT(e->off);
LPUT(e->size);
LPUT(e->link);
LPUT(e->info);
LPUT(e->addralign);
LPUT(e->entsize);
}
ElfShdr *
elfwritenotehdr(char *str, uint32 namesz, uint32 descsz, uint32 tag)
{
ElfShdr *sh;
sh = elfshname(str);
// Write Elf_Note header.
cseek(sh->off);
LPUT(namesz);
LPUT(descsz);
LPUT(tag);
return sh;
}
int
elfwritenetbsdsig(vlong stridx) {
ElfShdr *sh = nil;
int i;
for(i = 0; i < hdr.shnum; i++)
if(shdr[i]->name == stridx)
sh = shdr[i];
if(sh == nil)
return 0;
// Write Elf_Note header followed by NetBSD string.
cseek(sh->off);
LPUT(ELF_NOTE_NETBSD_NAMESZ);
LPUT(ELF_NOTE_NETBSD_DESCSZ);
LPUT(ELF_NOTE_TYPE_NETBSD_TAG);
cwrite(ELF_NOTE_NETBSD_NAME, 8);
LPUT(ELF_NOTE_NETBSD_VERSION);
return sh->size;
}
uint32
elf32writehdr(void)
{
int i;
for (i = 0; i < EI_NIDENT; i++)
cput(hdr.ident[i]);
WPUT(hdr.type);
WPUT(hdr.machine);
LPUT(hdr.version);
LPUT(hdr.entry);
LPUT(hdr.phoff);
LPUT(hdr.shoff);
LPUT(hdr.flags);
WPUT(hdr.ehsize);
WPUT(hdr.phentsize);
WPUT(hdr.phnum);
WPUT(hdr.shentsize);
WPUT(hdr.shnum);
WPUT(hdr.shstrndx);
return ELF32HDRSIZE;
}
static void
putelfsyment(int off, vlong addr, vlong size, int info, int shndx, int other)
{
switch(thechar) {
case '6':
LPUT(off);
cput(info);
cput(other);
WPUT(shndx);
VPUT(addr);
VPUT(size);
symsize += ELF64SYMSIZE;
break;
default:
LPUT(off);
LPUT(addr);
LPUT(size);
cput(info);
cput(other);
WPUT(shndx);
symsize += ELF32SYMSIZE;
break;
}
}
int
elfwriteopenbsdsig(void)
{
ElfShdr *sh;
// Write Elf_Note header.
sh = elfwritenotehdr(".note.openbsd.ident", ELF_NOTE_OPENBSD_NAMESZ, ELF_NOTE_OPENBSD_DESCSZ, ELF_NOTE_OPENBSD_TAG);
if(sh == nil)
return 0;
// Followed by OpenBSD string and version.
cwrite(ELF_NOTE_OPENBSD_NAME, ELF_NOTE_OPENBSD_NAMESZ);
LPUT(ELF_NOTE_OPENBSD_VERSION);
return sh->size;
}
static void
pewrite(void)
{
int i, j;
strnput("MZ", 0x3c);
LPUT(0x40); // file offset to PE header
strnput("PE", 4);
for (i=0; i<sizeof(fh); i++)
cput(((char*)&fh)[i]);
for (i=0; i<sizeof(oh); i++)
cput(((char*)&oh)[i]);
for (i=0; i<nsect; i++)
for (j=0; j<sizeof(sh[i]); j++)
cput(((char*)&sh[i])[j]);
}
void
putsymb(char *s, int t, long v, int ver)
{
int i, f;
if(t == 'f')
s++;
LPUT(v);
if(ver)
t += 'a' - 'A';
CPUT(t+0x80); /* 0x80 is variable length */
if(t == 'Z' || t == 'z') {
CPUT(s[0]);
for(i=1; s[i] != 0 || s[i+1] != 0; i += 2) {
CPUT(s[i]);
CPUT(s[i+1]);
}
CPUT(0);
CPUT(0);
i++;
}
else {
for(i=0; s[i]; i++)
CPUT(s[i]);
CPUT(0);
}
symsize += 4 + 1 + i + 1;
if(debug['n']) {
if(t == 'z' || t == 'Z') {
Bprint(&bso, "%c %.8lux ", t, v);
for(i=1; s[i] != 0 || s[i+1] != 0; i+=2) {
f = ((s[i]&0xff) << 8) | (s[i+1]&0xff);
Bprint(&bso, "/%x", f);
}
Bprint(&bso, "\n");
return;
}
if(ver)
Bprint(&bso, "%c %.8lux %s<%d>\n", t, v, s, ver);
else
Bprint(&bso, "%c %.8lux %s\n", t, v, s);
}
}
static int
lw_A(
FIOSPTR css,
char *ptr, /* Points to character data to be output */
int charlen,/* Length of data to be output */
long recsize,/* Number of characters per line for REPFLUSH */
unit *cup, /* Unit table pointer */
int errf, /* Error flag */
struct BUFFERS *bptr /* Structure containing formatting buffers */
)
{
int m;
char *aposptr;
int ss;
int fflag;
int recmax;
/*
* Copy the data into the formatting buffer. The data is
* surrounded by apostrophes. If there is an apostrophe in
* the data it must be output as two apostrophes.
*/
fflag = 0;
*bptr->f_lbufptr++ = (long) '\'';
bptr->f_lbufcnt++;
for (; charlen > 0; ) {
if (fflag == 0) {
recmax = recsize - 2;
m = MIN(charlen, recmax - bptr->f_lbufcnt);
}
else {
recmax = recsize - 1;
m = MIN(charlen, recmax - bptr->f_lbufcnt);
}
/* Is there an apostrophe in the data? */
aposptr = memchr(ptr, '\'', m);
if (aposptr != 0) {
/* aposptr points to next apostrophe */
m = aposptr + 1 - ptr;
/* Move everything up to, and including, apostrophe */
(void) _unpack(ptr, bptr->f_lbufptr, m, -1);
*(bptr->f_lbufptr + m) = '\''; /* Double apostrophe */
ptr = ptr + m;
charlen = charlen - m;
m++;
}
else {
/* Move everything */
(void) _unpack(ptr, bptr->f_lbufptr, m, -1);
ptr = ptr + m;
charlen = charlen - m;
}
bptr->f_lbufptr += m;
bptr->f_lbufcnt += m;
/*
* If we've filled a record, write it out.
*/
if (bptr->f_lbufcnt >= recmax) {
if (bptr->outcnt <= bptr->f_lbufcnt) {
REPFLUSH();
/* If this is a continuation of one */
/* character variable, start it in col. 2 */
/* Otherwise, start it in col. 3 */
if (fflag == 1) {
bptr->outptr--; /* start in col. 2 */
bptr->outcnt++;
}
fflag = 1;
}
bptr->f_lbufptr = bptr->f_lbuf;
_memwcpy(bptr->outptr, bptr->f_lbufptr,
bptr->f_lbufcnt);
bptr->outptr += bptr->f_lbufcnt;
bptr->outcnt -= bptr->f_lbufcnt;
bptr->f_lbufptr = bptr->f_lbuf;
bptr->f_lbufcnt = 0;
}
} /* for */
*bptr->f_lbufptr++ = (long) '\'';
bptr->f_lbufcnt++;
LPUT(OUT_SEP);
LPUT(' ');
LPUT(' ');
bptr->lcomma = 1;
if (bptr->outcnt <= bptr->f_lbufcnt) {
/* If there is not enough room in outbuff to copy
* in the contents of f_lbuf,
* write what's in outbuff
*/
REPFLUSH();
/* If this is a continuation of 1 character variable, */
/* start it in col. 2. Otherwise, start it in col. 3*/
if (fflag == 1) {
bptr->outptr--;
bptr->outcnt++;
}
}
bptr->f_lbufptr = bptr->f_lbuf;
_memwcpy(bptr->outptr, bptr->f_lbufptr, bptr->f_lbufcnt);
bptr->outptr += bptr->f_lbufcnt;
bptr->outcnt -= bptr->f_lbufcnt;
bptr->f_lbufptr = bptr->f_lbuf;
bptr->f_lbufcnt = 0;
return(0);
ret:
return(ss);
}
static int
l_write(
FIOSPTR css,
unit *cup, /* Current unit pointer */
void *dptr, /* Address of data */
unsigned elsize, /* Bytes per element (used for char type only)*/
int count, /* Number of elements */
int inc, /* Number of words per element */
int type, /* Type of data */
long recsize,/* Number of characters to output per line */
int errf,
struct BUFFERS *bptr /* Structure containing formatting buffers */
)
{
unsigned int len77;
char *cp; /* points to data if type is DT_CHAR */
long *ptr; /* points to data if type is not DT_CHAR */
long ugly[ITEMBUFSIZ]; /* temporary buffer used for numeric output */
long dig;
long exp;
long mod;
long scl;
long ss;
long wid;
long *ib_ptr; /* pointer into the current item buffer */
long *newp;
int lcount; /* repeat count of current input data group */
oc_func *gcf; /* Generic NOCV-type conversion func */
ftype_t f90type;
if (type == DT_CHAR) {
/*
* Character data is unique in that one value may span
* more than one record when output.
* When we can handle opening the output file with a
* 'DELIM=' descriptor (see Ansi 8x Fortran standard), this
* code will need to change. For now, delimit the constant
* with apostrophes, and double all internal apostrophes.
*/
cp = dptr;
len77 = elsize;
for (; count > 0; count-- ) {
bptr->lcomma = 0;
if (count > 1) {
/*
* If we have an array of character data,
* determine if any values are repeated.
*/
cp = char_rep(cp, count, len77, &lcount,
bptr);
count = count - (lcount - 1);
}
/* Write the character constant */
ss = lw_A(css, cp, len77, recsize, cup, errf, bptr);
if (ss != 0) {
RERR(css, ss);
}
cp = cp + len77;
} /* for */
return(0);
} /* if (type == DT_CHAR) */
/* Noncharacter data */
ptr = (long *)dptr;
f90type = _f77_to_f90_type_cnvt[type];
if ((type == DT_DBLE) || (type == DT_CMPLX))
inc = inc + inc;
for (; count > 0; count--, ptr += inc) {
if (count > 1) { /* find repeat values */
ptr = find_rep(ptr, count, inc, type, &lcount,
bptr);
count = count - (lcount - 1);
}
ib_ptr = bptr->f_lbufptr;
switch (type) { /* set up for each data type */
case DT_NONE:
gcf = _s2uo; mod = MODEUN; wid = WOCTWRD;
dig = WOCTWRD; exp = 0; scl = 0;
break;
case DT_SINT:
case DT_INT:
gcf = _s2ui; mod = 0; wid = WINT;
dig = 1; exp = 0; scl = 0;
break;
case DT_REAL:
case DT_CMPLX:
gcf = _sd2uge; mod = 0; wid = WREAL8;
dig = _dreal8; exp = DEXP8; scl = 1;
if (YMP80) dig = 9;
break;
case DT_DBLE:
/*
* When printing with D format, decrease
* the digits by one because we are setting
* the scale factor to 1. This ensures that
* _dreal16 digits of precision are printed.
*/
gcf = _sd2udee; mod = MODEDP; wid = WREAL16;
dig = _dreal16-1; exp = DEXP16; scl = 1;
if (YMP80) dig = 25;
break;
}
/*
* Perform the output conversion.
*/
switch (type) { /* set up for each data type */
default: /* Integer, Short Integer, Real, or Double */
#if _F_REAL16 == 1 /* suppress if _f_dble is not fully supported */
if (YMP80 && !cup->uft90 && type == DT_DBLE &&
*(_f_dble *)ptr == 0.0) {
static const char *zero_dp = "0.0E+00";
ib_ptr += _unpack(zero_dp, ib_ptr,
strlen(zero_dp), -1);
break;
}
#endif
newp = gcf(ptr, ugly, &mod, &wid, &dig, &exp, &scl);
if (type == DT_NONE)
*newp++ = 'B';
ib_ptr = ib_ptr + _wnl_beautify(f90type, ugly, newp,
ib_ptr, cup->uft90);
break;
case DT_CMPLX:
*ib_ptr++ = '(';
newp = gcf(ptr, ugly, &mod, &wid, &dig, &exp, &scl);
ib_ptr = ib_ptr + _wnl_beautify(f90type, ugly, newp,
ib_ptr, cup->uft90);
*ib_ptr++ = COMMA;
newp = gcf((_f_real *)ptr + 1, ugly,
&mod, &wid, &dig, &exp, &scl);
ib_ptr = ib_ptr + _wnl_beautify(f90type, ugly, newp,
ib_ptr, cup->uft90);
*ib_ptr++ = ')';
break;
case DT_LOG:
*ib_ptr++ = _lvtob(*(_f_log8 *)ptr)? 'T':'F';
break;
} /* switch */
/*
* Update the item buffer pointers before using LPUT again.
*/
bptr->f_lbufcnt += ib_ptr - bptr->f_lbufptr;
bptr->f_lbufptr = ib_ptr;
LPUT(OUT_SEP);
LPUT(' '); /* put 2 blanks between items */
LPUT(' ');
if (bptr->outcnt <= bptr->f_lbufcnt) {
/*
* If there is not enough room in the line buffer
* to copy the next output value, flush out the line
* and start a new line.
*/
REPFLUSH();
}
bptr->f_lbufptr = bptr->f_lbuf;
_memwcpy(bptr->outptr, bptr->f_lbufptr, bptr->f_lbufcnt);
bptr->outptr += bptr->f_lbufcnt;
bptr->outcnt -= bptr->f_lbufcnt;
bptr->f_lbufptr = bptr->f_lbuf;
bptr->f_lbufcnt = 0;
}
return(0);
ret:
return(ss);
}
int
@WNL(
_f_int *unump, /* Unit number or dataset name */
Namelist *nl, /* Namelist structure */
int errf /* Nonzero if ERR specified */
)
{
unum_t unum;
int errn;
int n, ss;
void *vaddr; /* variable address */
unsigned elsize; /* size in bytes of the variable */
long recsize; /* number of characters to output per
* line. Used by REPFLUSH.*/
char c; /* needed by NLPUTS macro */
char *s; /* needed by NLPUTS macro */
unit *cup; /* unit pointer */
Nlentry *nlent;
FIOSPTR css;
struct BUFFERS wnlbuffers;
struct BUFFERS *bptr;
bptr = &wnlbuffers;
bptr->f_lbuf = NULL;
unum = *unump;
GET_FIOS_PTR(css);
STMT_BEGIN(unum, 0, T_WNL, NULL, css, cup);
if (cup == NULL) { /* if not connected */
cup = _imp_open77(css, SEQ, FMT, unum, errf, &errn);
/*
* If the open failed, cup is NULL and errn contains
* the error number.
*/
if (cup == NULL)
RERR(css, errn);
}
/* Set various unit table fields */
cup->uflag = (errf != 0 ? _UERRF : 0);
cup->ulineptr = cup->ulinebuf;
cup->uwrt = 1; /* Set write flag */
/* Set fields in the Fortran statement state structure */
css->u.fmt.nonl = 0; /* Clear no-newline flag */
if (cup->useq == 0) /* If direct access file */
RERR(css, FESEQTIV); /* Sequential attempted on direct access */
if (!cup->ufmt) /* If unformatted file */
RERR(css, FEFMTTIV); /* Formatted attempted on unformatted */
if ((cup->uaction & OS_WRITE) == 0)
RERR(css, FENOWRIT);
bptr = &wnlbuffers;
bptr->lcomma = 0;
/*
* Set up record size. The hierarchy for determining Namelist
* output record size is as follows:
* 1) RECL, if specified
* 2) WNLLONG(), if set and does not exceed cup->urecsize
* 3) list-directed output record size (cup->uldwsize)
*
* Note that while (1) and (3) are established at OPEN time, (2)
* can be changed ``on the fly''; therefore, this check has to
* be performed here.
*/
recsize = cup->uldwsize;
if (cup->urecl == 0 && _wnlrecsiz > 0) /* No RECL and WNLLONG() set */
recsize = MIN(cup->urecsize, _wnlrecsiz);
bptr->outcnt = recsize - 1; /* First char. for carriage control */
bptr->outbuff = cup->ulinebuf;
bptr->outptr = bptr->outbuff;
*bptr->outptr++ = OUT_ECHO; /* First character of first line */
bptr->f_lbuf = (long *) malloc((recsize + 1) * sizeof(long));
if (bptr->f_lbuf == NULL)
RERR(css, FENOMEMY); /* No memory */
/* NAMELIST delimiter to output line */
NLPUT(OUT_CHAR); /* output delimiter */
NLPUTS(nl->nlname); /* unpack group name to buffer */
NLPUT(' ');
NLPUT(' ');
NLINE(); /* Did user specify new line for each variable? */
nlent = nl->nlvnames;
do {
int ntype;
ntype = _old_namelist_to_f77_type_cnvt[nlent->na.type];
/*
* Always format output into f_lbufptr.
* After formatting, if it will fit, move it into outbuff.
* If it will not fit, write out what is already in outbuff,
* and then move in the newly formatted data.
*/
bptr->f_lbufptr = bptr->f_lbuf;
bptr->f_lbufcnt = 0;
LPUTS(nlent->varname); /* output variable name */
LPUT(' ');
LPUT(OUT_EQ); /* output the replacement
* character. '=' by default. */
n = (nlent->na.offdim) ? nlent->na.nels : 1;
if (ntype == DT_CHAR) {
_fcd f;
f = *(_fcd *)(((unsigned long) nlent->va.varaddr +
(long *)nl));
vaddr = _fcdtocp(f);
elsize = _fcdlen(f);
}
else {
vaddr = (void *)nlent->va.varaddr;
elsize = 0;
}
LPUT(' ');
/* Output value */
ss = l_write(css, cup, vaddr, elsize, n, 1, ntype, recsize,
errf, bptr);
if (ss != 0) {
RERR(css, ss);
}
NLINE();
nlent++; /* point to next variable description */
} while (nlent->varname[0]);
if (bptr->outcnt < 6) {
REPFLUSH(); /* Make sure there's room for " &END" */
bptr->outptr--; /* start in col. 2 */
bptr->outcnt++;
}
NLPUT(OUT_CHAR);
NLPUTS("END");
REPFLUSH();
ret:
STMT_END(cup, T_WNL, NULL, css); /* Unlock the unit */
if (bptr->f_lbuf != NULL) /* Free formatting buffer */
free(bptr->f_lbuf);
return(CFT77_RETVAL(ss));
}
void
lput(long l)
{
LPUT(l);
}
void
objput(int32_t l) /* emit long in byte order appropriate to object machine */
{
LPUT(l);
}