home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d3xx / d386 / xlispstat.lha / XLispStat / src3.lzh / UNIX / xsdynload.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-07-30  |  19.3 KB  |  673 lines
  1. /* xsdynload - Dynamic loading and C function calling routines.        */
  2. /* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney                  */
  3. /* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz    */
  4. /* You may give out copies of this software; for conditions see the    */
  5. /* file COPYING included with this distribution.                       */
  6.  
  7. /* Calling conventions are based on the conventions given in the New S */
  8. /* book. Calling conventions for dyn-load are based on a combination   */
  9. /* KCL's si:faslink conventions and Bill Dunlap's dyn.load2 for New S. */
  10. /*                                                                     */
  11. /* The dynamic loading code is based on the KCL faslink function and   */
  12. /* Bill Dunlap's dynamic loader for New S.                             */
  13.  
  14. #ifdef FOREIGNCALL 
  15. #include "xlisp.h"
  16.  
  17. #define nil 0L
  18.  
  19. #define seqlen(x) ((vectorp(x)) ? getsize(x) : llength(x))
  20.  
  21. extern char buf[];
  22. extern char *progname;
  23. extern LVAL s_true, k_verbose;
  24.  
  25. extern LVAL newvector(), make_string(), mklist(), getnextelement();
  26. extern double makedouble();
  27.  
  28. typedef int  (*pfi_t)();     /* pointer to function returning integer. */
  29. typedef LVAL (*pfl_t)();     /* pointer to function returning LVAL.    */
  30.  
  31. #define HASHSIZE 397
  32.  
  33. static int verbose;
  34. static LVAL s_cfun_table = NIL;
  35. static char lbuf[100];
  36.  
  37. #include "foreign.h"
  38.  
  39. /************************************************************************/
  40. /**                                                                    **/
  41. /**           Public Allocation and Error Signalling Functions         **/
  42. /**                                                                    **/
  43. /************************************************************************/
  44.  
  45. static LVAL current_allocs;
  46.  
  47. /* allocate space that will be garbage collected after return */
  48. char *xscall_alloc(n, m)
  49.      int n, m;
  50. {
  51.   LVAL adata;
  52.   char *p;
  53.  
  54.   adata = newadata(n, m, FALSE);
  55.   if (adata == NIL || (p = getadaddr(adata)) == nil)
  56.     xlfail("allocation failed");
  57.   current_allocs = cons(adata, current_allocs);
  58.   return(p);
  59. }
  60.  
  61. /* error routint for use within C functions */
  62. xscall_fail(s) char *s; { xlfail(s); }
  63.  
  64. /************************************************************************/
  65. /**                                                                    **/
  66. /**                Lisp to C/FORTRAN Data Conversion                   **/
  67. /**                                                                    **/
  68. /************************************************************************/
  69.  
  70. #define IN 0
  71. #define RE 1
  72. #define MAXARGS 15
  73.  
  74. typedef struct {
  75.   int type, size;
  76.   char *addr;
  77. } call_arg;
  78.  
  79. /* convert lisp argument to allocated pointer */
  80. static call_arg lisp2arg(x)
  81.      LVAL x;
  82. {
  83.   call_arg a;
  84.   LVAL elem, data;
  85.   int i;
  86.  
  87.   xlprot1(x);
  88.  
  89.   /* make sure x is a sequence and find its length */
  90.   if (! sequencep(x)) x = consa(x);
  91.   a.size = seqlen(x);
  92.  
  93.   /* determine the mode of the data */
  94.   for (i = 0, a.type = IN, data = x; i < a.size; i++) {
  95.     elem = getnextelement(&data, i);
  96.     if (floatp(elem)) a.type = RE;
  97.     else if (! fixp(elem)) xlerror("not a real number", elem);
  98.   }
  99.  
  100.   /* allocate space for the data */
  101.   a.addr = xscall_alloc(a.size, (a.type == IN) ? sizeof(int) : sizeof(double));
  102.  
  103.   /* fill the space */
  104.   for (i = 0, data = x; i < a.size; i++) {
  105.     elem = getnextelement(&data, i);
  106.     if (a.type == IN) ((int *) a.addr)[i] = getfixnum(elem);
  107. #if !(defined(ibm032) && defined(__HIGHC__))
  108.     else ((double *) a.addr)[i] = makedouble(elem);
  109. #else /* avoid bug in hc 2.1n C compiler on IBM RT running AOS 4.3 */
  110.     else {
  111.       double *dbl = &((double *)a.addr)[i] ;
  112.       *dbl = makedouble(elem) ;
  113.     }
  114. #endif
  115.   }
  116.   
  117.   xlpop();
  118.   return(a);
  119. }
  120.  
  121. /* copy allocated pointer back to new lisp list */
  122. static LVAL arg2lisp(a)
  123.      call_arg a;
  124. {
  125.   LVAL x, next;
  126.   int i;
  127.  
  128.   xlsave1(x);
  129.   x = mklist(a.size, NIL);
  130.   for (i = 0, next = x; i < a.size; i++, next = cdr(next)) {
  131.     if (a.type == IN) rplaca(next, cvfixnum((FIXTYPE) ((int *) a.addr)[i]));
  132.     else rplaca(next, cvflonum((FLOTYPE) ((double *) a.addr)[i]));
  133.   }
  134.   xlpop();
  135.   return(x);
  136. }
  137.  
  138. /************************************************************************/
  139. /**                                                                    **/
  140. /**                Foreign Function Call Functions                     **/
  141. /**                                                                    **/
  142. /************************************************************************/
  143.  
  144. static LVAL call_foreign(which)
  145.      int which;
  146. {
  147.   LVAL result, name, old_allocs, next;
  148.   call_arg args[MAXARGS], *pargs;
  149.   int nargs;
  150.   int (*routine)();
  151.   char *get_caddress();
  152.   char *pattern;
  153.  
  154.   xlstkcheck(3);
  155.   xlsave(old_allocs);
  156.   xlprotect(current_allocs);
  157.   xlsave(result);
  158.   old_allocs = current_allocs;
  159.   current_allocs = NIL;
  160.  
  161.   /* get the routine pointer */
  162.   name = xlgastring();
  163.   pattern = (which == 'C') ? INTERNAL_CNAME_PATTERN : INTERNAL_FNAME_PATTERN;
  164.   sprintf(lbuf, pattern, getstring(name));
  165.   routine = (pfi_t) get_caddress(lbuf);
  166.   if (! routine) xlerror("can't find internal symbol by this name", name);
  167.  
  168.   /* convert the arguments to allocated pointers */
  169.   for (nargs = 0; moreargs(); nargs++) {
  170.     if (nargs >= MAXARGS) xlfail("too many arguments");
  171.     args[nargs] = lisp2arg(xlgetarg());
  172.   }
  173.  
  174.   /* make the call -- there must be a better way to do this */
  175.   switch (nargs) {
  176.   case  0: routine(); break;
  177.   case  1: routine(args[0].addr); break;
  178.   case  2: routine(args[0].addr, args[1].addr); break;
  179.   case  3: routine(args[0].addr, args[1].addr, args[2].addr); break;
  180.   case  4: 
  181.     routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr);
  182.     break;
  183.   case  5: 
  184.     routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr, 
  185.         args[4].addr);
  186.     break;
  187.   case  6:
  188.     routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr,
  189.         args[4].addr, args[5].addr); 
  190.     break;
  191.   case  7:
  192.     routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr,
  193.         args[4].addr, args[5].addr, args[6].addr); 
  194.     break;
  195.   case  8:
  196.     routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr, 
  197.         args[4].addr, args[5].addr, args[6].addr, args[7].addr); 
  198.     break;
  199.   case  9: 
  200.     routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr, 
  201.         args[4].addr, args[5].addr, args[6].addr, args[7].addr, 
  202.         args[8].addr); 
  203.     break;
  204.   case 10: 
  205.     routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr, 
  206.         args[4].addr, args[5].addr, args[6].addr, args[7].addr, 
  207.         args[8].addr, args[9].addr); 
  208.     break;
  209.   case 11: 
  210.     routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr, 
  211.         args[4].addr, args[5].addr, args[6].addr, args[7].addr, 
  212.         args[8].addr, args[9].addr, args[10].addr); 
  213.     break;
  214.   case 12: 
  215.     routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr, 
  216.         args[4].addr, args[5].addr, args[6].addr, args[7].addr, 
  217.         args[8].addr, args[9].addr, args[10].addr, args[11].addr); 
  218.     break;
  219.   case 13: 
  220.     routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr, 
  221.         args[4].addr, args[5].addr, args[6].addr, args[7].addr, 
  222.         args[8].addr, args[9].addr, args[10].addr, args[11].addr,
  223.         args[12].addr); 
  224.     break;
  225.   case 14: 
  226.     routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr, 
  227.         args[4].addr, args[5].addr, args[6].addr, args[7].addr, 
  228.         args[8].addr, args[9].addr, args[10].addr, args[11].addr,
  229.         args[12].addr,  args[13].addr); 
  230.     break;
  231.   case 15: 
  232.     routine(args[0].addr, args[1].addr, args[2].addr, args[3].addr, 
  233.         args[4].addr, args[5].addr, args[6].addr, args[7].addr, 
  234.         args[8].addr, args[9].addr, args[10].addr, args[11].addr,
  235.         args[12].addr,  args[13].addr, args[14].addr); 
  236.     break;
  237.   }
  238.   
  239.   /* convert the pointers back to lists, grouped in a list */
  240.   result = (nargs > 0) ? mklist(nargs, NIL) : NIL;
  241.   for (next = result, pargs = args; consp(next); next = cdr(next), pargs++)
  242.     rplaca(next, arg2lisp(*pargs));
  243.   
  244.   current_allocs = old_allocs;
  245.   xlpopn(3);
  246.  
  247.   return(result);
  248. }
  249.  
  250. /* CALL-CFUN */
  251. LVAL xscall_cfun() { return(call_foreign('C')); }
  252.  
  253. /* CALL-FSUB */
  254. LVAL xscall_fsub() { return(call_foreign('F')); }
  255.  
  256. /* CALL-LFUN */
  257. LVAL xscall_lfun()
  258. {
  259.   LVAL name, old_allocs, result;
  260.   LVAL (*routine)();
  261.   char *get_caddress();
  262.   
  263.   xlstkcheck(2);
  264.   xlsave(old_allocs);
  265.   xlprotect(current_allocs);
  266.   old_allocs = current_allocs;
  267.   current_allocs = NIL;
  268.  
  269.   name = xlgastring();
  270.   sprintf(lbuf, INTERNAL_CNAME_PATTERN, getstring(name));
  271.  
  272.   routine = (pfl_t) get_caddress(lbuf);
  273.   if (! routine) xlerror("can't find internal symbol by this name", name);
  274.   result = routine();
  275.   current_allocs = old_allocs;
  276.   xlpopn(2);
  277.  
  278.   return(result);
  279. }
  280.  
  281. /************************************************************************/
  282. /**                                                                    **/
  283. /**                   Fake COFF ldfcn's for BSD                        **/
  284. /**                                                                    **/
  285. /************************************************************************/
  286.  
  287. #ifdef STDBSD
  288.  
  289. #define LDFILE FILE
  290. #define SYMENT struct nlist
  291. #define SUCCESS TRUE
  292. #define FAILURE FALSE
  293. #define LDNAMELIMIT 100
  294. #define AOUTHDR struct exec
  295. #define SCNHDR AOUTHDR
  296. #define FREAD fread
  297.  
  298. static struct exec header;
  299. static char ldnamebuf[LDNAMELIMIT];
  300.  
  301. static LDFILE *ldopen(name, dummy)
  302.      char *name, *dummy;
  303. {
  304.   LDFILE *fp;
  305.  
  306.   if ((fp = fopen(name, "r")) == NULL) xlfail("cannot open ld file");
  307.   if (fread((char *) &header, sizeof(header), 1, fp) != 1 ||
  308.       feof(fp) || ferror(fp)) {
  309.     fclose(fp);
  310.     fp = NULL;
  311.   }
  312.   return(fp);
  313. }
  314.  
  315. static ldtbread(fp, i, psym)
  316.      LDFILE *fp;
  317.      int i;
  318.      SYMENT *psym;
  319. {
  320.   if (i < 0 || i >= header.a_syms / sizeof(SYMENT)) return(FAILURE);
  321.   if (fseek(fp, N_SYMOFF(header) + i * sizeof(SYMENT), 0) < 0) return(FAILURE);
  322.   if (fread((char *) psym, sizeof(SYMENT), 1, fp) != 1 ||
  323.       feof(fp) || ferror(fp)) return(FAILURE);
  324.   return(SUCCESS);
  325. }
  326.  
  327. static char *ldgetname(fp, psym)
  328.      LDFILE *fp;
  329.      SYMENT *psym;
  330. {
  331.   char *bp = ldnamebuf;
  332.   long which = psym->n_un.n_strx;
  333.   int i = 0;
  334.  
  335.   *bp = '\0';
  336.   if (which) {
  337.     ok_fseek(fp, N_STROFF(header) + which, 0);
  338.     while ((*bp++ = getc(fp)) != '\0') 
  339.       if (++i >= LDNAMELIMIT) xlfail("name too long for ld buffer");
  340.   }
  341.   return(ldnamebuf);
  342. }
  343.  
  344. static ldohseek(fp)
  345.      LDFILE *fp;
  346. {
  347.   if (fseek(fp, 0, 0) < 0) return(FAILURE);
  348.   else return(SUCCESS);
  349. }
  350.  
  351. static ldclose(fp)
  352.      LDFILE *fp;
  353. {
  354.   fclose(fp);
  355.   return(SUCCESS);
  356. }
  357.  
  358. #endif STDBSD
  359.  
  360. /************************************************************************/
  361. /**                                                                    **/
  362. /**                   Dynamic Loading Functions                        **/
  363. /**                                                                    **/
  364. /************************************************************************/
  365.  
  366. extern char *calloc();
  367.  
  368. #define round_up(a, d) ((long)(a)%(d) ? (d)*((long)(a)/(d) + 1) : (long)(a))
  369.  
  370. #ifdef STDBSD
  371. #define SYMVALUE(sym) ((char *) ((sym).n_value))
  372. #ifndef SYM_IS_GLOBAL_FUNCTION
  373. #define SYM_IS_GLOBAL_FUNCTION(ldptr,symbol) \
  374.   (((symbol).n_type & N_TYPE) == N_TEXT  && ((symbol).n_type & N_EXT))
  375. #endif /* SYM_IS_GLOBAL_FUNCTION */
  376. #endif STDBSD
  377.  
  378. /* DYN-LOAD function */
  379. LVAL xsdynload()
  380. {
  381.   char *name, *libs;
  382.   LVAL flag, arg;
  383.   LVAL k_fortran = xlenter(":FORTRAN");
  384.   LVAL k_libflags = xlenter(":LIBFLAGS");
  385.   int fort;
  386.  
  387.   name = (char *) getstring(xlgastring());
  388.   if (! xlgetkeyarg(k_verbose, &flag)) flag = (VERBDFLT) ? s_true : NIL;
  389.   verbose = flag != NIL;
  390.   if (! xlgetkeyarg(k_fortran, &flag)) flag = NIL;
  391.   fort = flag != NIL;
  392.   if (xlgetkeyarg(k_libflags, &arg) && stringp(arg))
  393.     libs = (char *) getstring(arg);
  394.   else libs = "";
  395.  
  396.   link_and_load(name, libs, fort);
  397.  
  398.   return(s_true);
  399. }
  400.  
  401. static enter_csymbol(name, addr)
  402.      char *name, *addr;
  403. {
  404.   LVAL table, list, entry;
  405.   int i;
  406.  
  407.   if (s_cfun_table == NIL) {
  408.     s_cfun_table = xlenter("__cfun_table__");
  409.     setvalue(s_cfun_table, newvector(HASHSIZE));
  410.   }
  411.   
  412.   table = getvalue(s_cfun_table);
  413.   if (arrayp(table)) {
  414.     i = hash(name, getsize(table));
  415.     
  416.     /* see if name is already in the table; replace its value if it is */
  417.     for (list = getelement(table, i); consp(list); list = cdr(list)) {
  418.       entry = car(list);
  419.       if (stringp(car(entry)) && strcmp(name, getstring(car(entry))) == 0) {
  420.     rplacd(entry, cvfixnum((FIXTYPE) addr));
  421.     return;
  422.       }
  423.     }
  424.  
  425.     /* otherwise (not returned yet) make a new entry */
  426.     entry = cons(NIL, NIL);
  427.     setelement(table, i, cons(entry, getelement(table, i)));
  428.     rplaca(entry, make_string(name));
  429.     rplacd(entry, cvfixnum((FIXTYPE) addr));
  430.   }
  431. }
  432.  
  433. static char *find_hash_entry(name)
  434.      char *name;
  435. {
  436.   LVAL table, entry, list;
  437.   int i;
  438.  
  439.   if (! symbolp(s_cfun_table)) return(NULL);
  440.  
  441.   table = getvalue(s_cfun_table);
  442.   if (arrayp(table)) {
  443.     i = hash(name, getsize(table));
  444.     for (list = getelement(table, i); consp(list); list = cdr(list)) {
  445.       entry = car(list);
  446.       if (stringp(car(entry)) && strcmp(name, getstring(car(entry))) == 0)
  447.     return((fixp(cdr(entry))) ? (char *) getfixnum(cdr(entry)) : NULL);
  448.     }
  449.   }
  450.   return (NULL);
  451. }
  452.  
  453. static char *get_caddress(name)
  454.      char *name;
  455. {
  456.   struct nlist nl[2];
  457.   char *addr;
  458.  
  459.   if ((addr = find_hash_entry(name)) != NULL) return(addr);
  460.   else {
  461. #ifdef COFF_FORMAT
  462.     nl[0].n_name = name;
  463.     nl[1].n_name = "";
  464. #else
  465.     nl[0].n_un.n_name = name;
  466.     nl[1].n_un.n_name = "";
  467. #endif
  468.     if (nlist(progname, nl) == -1)
  469.       xlfail("file not found or invalid name list");
  470.     if((addr = (char *) nl[0].n_value) != NULL) {
  471.       enter_csymbol(name, addr);
  472.       return(addr);
  473.     }
  474.     else return (NULL);
  475.   }
  476. }
  477.  
  478. #ifdef STATIC_LOAD_ONLY
  479. static link_and_load(fname, libs, fort)
  480.      char *fname, *libs;
  481.      int fort;
  482. {
  483.   xlfail("dynamic loading not available on this system");
  484. }
  485. #else
  486. #ifndef HAS_OWN_DYNLOAD
  487. static link_and_load(fname, libs, fort)
  488.      char *fname, *libs;
  489.      int fort;
  490. {
  491.   char tmpfname[TMPNAMESIZE];
  492.   char *code_start, *addr, *syslibs;
  493.   int size, size_guess;
  494.   
  495.   /* make the libstring, the tempfile name and the initial code space */
  496.   syslibs = (fort) ? FLIBS : CLIBS;
  497.   sprintf(tmpfname, TMPPATTERN, getpid());
  498.   size_guess = MIN_ALLOC;
  499.   addr = calloc(1, size_guess);
  500.   if (addr == nil) xlfail("can't make initial code allocation");
  501.   code_start = (char *) round_up(addr, PAGE_SIZE);
  502.   size_guess -= (long) (code_start - addr); 
  503.  
  504.   /* do an incremental load of the file and libs against xlisp */
  505.   sprintf(buf, LDPATTERN, 
  506.       progname, (int) code_start, fname, libs, syslibs, tmpfname);
  507.   if (verbose) printf("first ld pass\n%s\n", buf);
  508.   if (system(buf) != 0) {
  509.     free(addr);
  510.     xlfail("link failed");
  511.   }
  512.  
  513.   /* check the code size and redo the load if needed */
  514.   size = code_size(tmpfname, code_start);
  515.   if (size_guess < size) {
  516.     free(addr);
  517.     addr = calloc(1, size + PAGE_SIZE);
  518.     if (addr == nil) xlfail("can't make code allocation");
  519.     code_start = (char *) round_up(addr, PAGE_SIZE);
  520.     sprintf(buf, LDPATTERN, 
  521.         progname, (int) code_start, fname, libs, syslibs, tmpfname);
  522.     if (verbose) printf("second ld pass\n%s\n", buf);
  523.     if (system(buf) != 0) { 
  524.       free(addr); 
  525.       xlfail("link failed"); 
  526.     }
  527.     if (size < code_size(tmpfname, code_start)) {
  528.       free(addr);
  529.       xlfail("can't figure out tempfile size");
  530.     }
  531.   }
  532.  
  533.   /* read in the object file */
  534.   if (verbose) printf("reading in the code ..."); fflush(stdout);
  535.   read_code(tmpfname, code_start);
  536.   if (verbose) printf("done\n");
  537.  
  538.   /* enter the external symbols into the hash table */
  539.   if (verbose) printf("entering symbols..."); fflush(stdout);
  540.   enter_symbols(tmpfname);
  541.   if (verbose) printf("done\n");
  542.  
  543.   /* unlink the tempfile */
  544.   unlink(tmpfname);
  545. }
  546.  
  547. static code_size(tmpfname, code_start)
  548.      char *tmpfname, *code_start;
  549. {
  550.   LDFILE *fp;
  551.   AOUTHDR header;
  552.   SCNHDR scnheader;
  553.   int size;
  554.  
  555.   if ((fp = ldopen(tmpfname, NULL)) == NULL)
  556.     xlfail("cannot open temporary ld file");
  557.  
  558.   if (ldohseek(fp) == FAILURE) xlfail("could not seek to a.out header");
  559.   if (FREAD((char *) &header, sizeof(header), 1, fp) < 1)
  560.     xlfail("could not read a.out header");
  561.  
  562. #ifdef COFF_FORMAT
  563.   /* read last section header and measure size from code start */
  564.   /* section numbers begin with one!                           */
  565.   if (ldshread(fp, (unsigned short) N_SECTIONS(fp), &scnheader)==FAILURE)
  566.     xlfail("cannot read object file section");
  567.   size = SCN_ADDR(fp, scnheader) + SCN_LENGTH(fp, scnheader) 
  568.     - (long) code_start;
  569. #else
  570.   size = header.a_text + header.a_data + header.a_bss;
  571. #endif COFF_FORMAT
  572.  
  573.   if (ldclose(fp) == FAILURE) xlfail("cannot close tempfile");
  574.   return(size);
  575. }
  576.  
  577. static read_code(tmpfname, addr)
  578.      char *tmpfname, *addr;
  579. {
  580.   LDFILE *fp;
  581.   AOUTHDR header;
  582.   SCNHDR scnheader;
  583.   int size, i;
  584.  
  585.   if ((fp = ldopen(tmpfname, NULL)) == NULL)
  586.     xlfail("cannot open temporary ld file");
  587.   
  588.   if (ldohseek(fp) == FAILURE) xlfail("could not seek to a.out header");
  589.   if (FREAD((char *) &header, sizeof(header), 1, fp) < 1)
  590.     xlfail("could not read a.out header");
  591.  
  592. #ifdef COFF_FORMAT
  593.   /* read in code and data sections, zero out bss sections */
  594.   /* zeroing should not be needed since space came from    */
  595.   /* calloc, but it can't hurt.                            */
  596.   /* section numbers begin with one!                       */
  597.   for (i = 1 ; i <= N_SECTIONS(fp) ; i++) {
  598.     if (ldshread(fp, (unsigned short) i, &scnheader)==FAILURE)
  599.       xlfail("cannot read object file section");
  600.     if (SCN_IS_BSS(fp, scnheader))
  601.       bzero((char *) SCN_ADDR(fp, scnheader),
  602.         (int) SCN_LENGTH(fp, scnheader));
  603.     else {
  604.       if (FSEEK(fp, SCN_FILE_LOC(fp, scnheader), 0) == -1)
  605.     xlfail("could not seek to object file section");
  606.       if (FREAD((char *) SCN_ADDR(fp, scnheader), 1,
  607.         (int) SCN_LENGTH(fp, scnheader), fp)
  608.       < SCN_LENGTH(fp, scnheader))
  609.     xlfail("could not read object file section");
  610.     }
  611.   }
  612. #else
  613.   ok_fseek(fp, (long) N_TXTOFF(header), 0);
  614.   size = header.a_text + header.a_data;
  615.   ok_fread((char *) addr, 1, size, fp);
  616. #endif
  617.   
  618.   if (ldclose(fp) == FAILURE) xlfail("cannot close tempfile");
  619. }
  620.  
  621. static enter_symbols(tmpfname)
  622.      char *tmpfname;
  623. {
  624.   LDFILE *input;
  625.   SYMENT symbol;
  626.   char *symname, *symaddr;
  627.   int i;
  628.  
  629.   /* open the file */
  630.   if ((input = ldopen(tmpfname, NULL)) == NULL)
  631.     xlfail("cannot open tempfile for symbol reading");
  632.  
  633.   /* process symbols while they last */
  634.   i = 0;
  635.   while (ldtbread(input, i, &symbol) == SUCCESS) {
  636.     i++;
  637.     if (SYM_IS_GLOBAL_FUNCTION(input, symbol)) {
  638.       symname = ldgetname(input, &symbol);
  639.       symaddr = SYMVALUE(symbol);
  640.       enter_csymbol(symname, symaddr);
  641.     }
  642.   }
  643.   if (ldclose(input) == FAILURE) xlfail("cannot close tempfile");
  644. }
  645.  
  646. /************************************************************************/
  647. /**                                                                    **/
  648. /**                       Utility Functions                            **/
  649. /**                                                                    **/
  650. /************************************************************************/
  651.  
  652. static ok_fread(ptr, size, nitems, stream)
  653.      char *ptr;
  654.      int size, nitems;
  655.      FILE *stream;
  656. {
  657.   if (fread(ptr, size, nitems, stream) != nitems ||
  658.       feof(stream) || ferror(stream))
  659.     xlfail("error while reading disk file");
  660. }
  661.  
  662. static ok_fseek(stream, offset, ptrname)
  663.      FILE *stream;
  664.      long offset;
  665.      int ptrname;
  666. {
  667.   if (fseek(stream, offset, ptrname) < 0)
  668.     xlfail("error while seeking on disk file");
  669. }
  670. #endif HAS_OWN_DYNLOAD
  671. #endif STATIC_LOAD_ONLY
  672. #endif FOREIGNCALL
  673.