scsh-0.5/unix.c

/* Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
   See file COPYING. */

/*
   If you have concrete suggestions for improvements, they are quite
   welcome.  Please send them to scheme-48-bugs@martigny.ai.mit.edu.

   Non-Posixisms:

   The most annoying thing here is char_ready_p, which is needed for
   R^nRS and is nonportable in two different ways.  There's no
   portable (Posix or anything else) way to figure whether a stdio
   stream has buffered input.  And even if we knew that, there's no
   portable way to find out whether input would block - select() seems
   to be a BSD thing, and AT&T's ioctl() doesn't work for arbitrary
   devices.  If it can't figure out what to do, it just prints a
   warning and returns #t.

   setitimer(), a Berkeleyism, is used if it's available; otherwise
   alarm() is used, which only has 1-second resolution.  Timer
   interrupts are used by the threads apckage but not by the base
   system.

   gettimeofday() is BSD.  ftime() is Version 7 (!).  The POSIX.1/ANSI
   C alternative to these is time(), which returns a number of
   seconds.  There seems to be some disagreement over the number of
   arguments to gettimeofday().

   nlist() derives from ancient Version 6 and 7 unix, so it's pretty
   widespread, but everyone wants to phase it out because it's not
   very abstract.

   Access to a COFF symbol table via ldtbread is even less abstract,
   really sucks in general, and should be banned from earth.
   Probably only AIX needs it because of the broken nlist.

   Posix/ANSI C things used:
     feof fopen fprintf perror strlen strncpy etc.
     time (if gettimeofday and ftime are unavailable)

   Posix things used: (beware, PC and Mac hackers)
     alarm (if setitimer is unavailable)
     fileno (but only when select is being used)
     getenv getpwnam sigaction sysconf
     times  -- clock() is ANSI but wraps around every 36 minutes

   Other things used (BSD etc.), only when available:
     ftime (if gettimeofday is unavailable)
     gettimeofday
     nlist
     select
     setitimer

   <time.h> is ANSI C, but we apparently don't use anything from it
   that is part of ANSI C.  Under HPUX, the man pages tell one to
   use it in order to get declarations for the things that under SunOS
   are declared in <sys/time.h>.  Oh well, it can't hurt, can it?  Oh
   yeah, this is Unix, of course it can...
*/

#include "sysdep.h"

#include <stdio.h>
#include <stdlib.h>		/* for getenv(), etc. (POSIX?/ANSI) */
#include <string.h>		/* for strncpy(), etc. (POSIX/ANSI) */
#include <pwd.h>		/* for getpwnam() (POSIX.1) */
#include <unistd.h>		/* for sysconf() (POSIX.1/.2)*/
#include <sys/times.h>		/* for times() (POSIX.1) */
#include <signal.h>		/* for sigaction() (POSIX.1) */

#if defined(HAVE_POSIX_TIME_H)
#  include <posix/time.h>	/* RISC/OS + gcc lossage */
#  define _XOPEN_SOURCE 1
#else
#  include <time.h>
#endif

#if defined(HAVE_SETITIMER) || defined(HAVE_GETTIMEOFDAY)
#  include <sys/time.h>		/* for struct itimerval, ITIMER_REAL (Sun) */
#endif

#if defined(HAVE_SELECT)
#  include <sys/types.h>	/* for FD_SET and friends (BSD) */
#if defined(HAVE_SYS_SELECT_H)
#  include <sys/select.h>
#endif
#endif

#if defined(HAVE_SYS_TIMEB_H)
#  include <sys/timeb.h>	/* for ftime() */
#endif

#if defined(HAVE_NLIST)
#  include <nlist.h>		/* conforms to "SVID2", whatever that is */
#endif


#define INTERRUPT_ALARM     0	/* Cf. rts/arch.scm */
#define INTERRUPT_KEYBOARD  1

extern long Spending_interruptsS;


/* Signal handlers */

static RETSIGTYPE
when_keyboard_interrupt(sig, code, scp)
     int sig, code; 
     struct sigcontext *scp;
{
  Spending_interruptsS |= (1 << INTERRUPT_KEYBOARD);
  /* The following might be necessary with signal(), but shouldn't be
     with sigaction() (I think) */
  /* sigaction(SIGINT, &keyboard_action, NULL); */
  return;
}

static RETSIGTYPE
when_alarm_interrupt(sig, code, scp)
     int sig, code; 
     struct sigcontext *scp;
{
  Spending_interruptsS |= (1 << INTERRUPT_ALARM);
  return;
}


/* OS-dependent initialization */

static struct sigaction keyboard_action;
static struct sigaction alarm_action;

void
sysdep_init()
{
  keyboard_action.sa_handler = when_keyboard_interrupt;
  keyboard_action.sa_flags = 0;
  sigemptyset(&keyboard_action.sa_mask);

  alarm_action.sa_handler = when_alarm_interrupt;
  alarm_action.sa_flags = 0;
  sigemptyset(&alarm_action.sa_mask);

  sigaction(SIGINT, &keyboard_action, NULL);

  /* SIGPIPE's are bogus. -Olin */
  {struct sigaction sa;
   sa.sa_handler = SIG_IGN;
   sigemptyset(&sa.sa_mask);
   sa.sa_flags = 0;
   sigaction(SIGPIPE, &sa, NULL);	
   }
}

/* ---------------------------------------- */
/* For char-ready? */

int
char_ready_p( FILE* stream )
{
  struct timeval timeout;
  static int warnedp = 0;

  if (feof(stream))
    return EOF;

#ifndef KLUDGY
  if (fbufcount(stream) > 0)
    return 1;
#else
  /* Grossly unportable examination of stdio buffer internals. */
#if defined(FILE_HAS__CNT)
  if (stream->_cnt)
    return 1;
#elif defined(__linux__)
  if (stream->_IO_read_ptr < stream->_IO_read_end)
    return 1;
#elif defined(BSD) && (BSD >= 199306)
  if (stream->_r)
    return 1;
#else

  /* Add new cases here AND SEND THEM TO scheme-48@martigny.ai.mit.edu
     SO THAT THEY CAN GO INTO THE NEXT RELEASE!  (That means you, Olin.)
     It's generally pretty easy to figure out what to put here by
     examining /usr/include/stdio.h.  If the input stream's buffer is
     nonempty, just return any positive value. */
  if (!warnedp) {
    fprintf(stderr, "Warning: incomplete char-ready? implementation.\n");
    warnedp = 1; }
  return 1;
#endif
#endif

  /* Nothing in the buffer.  Find out whether a read would block. */
#if defined(HAVE_SELECT)
  {  fd_set readfds;
     FD_ZERO(&readfds);
     FD_SET(fileno(stream), &readfds);
     timerclear(&timeout);
     return select1(FD_SETSIZE, &readfds, NULL, NULL, &timeout);
     }
#else /* No select() - but there will generally be some other way to do this.*/
  if (!warnedp) {
    fprintf(stderr, "Warning: incomplete char-ready? implementation.\n");
    warnedp = 1; }
  return 1;
#endif
}

/* ---------------------------------------- */
/* For open-xxput-file */

FILE *
ps_open(char *filename, char *spec)
{
# define FILE_NAME_SIZE 256
  char filename_temp[FILE_NAME_SIZE];
  char *expanded;
  extern char *expand_file_name(char *, char *, int);

  expanded = expand_file_name(filename, filename_temp, FILE_NAME_SIZE);
  if (expanded == NULL)
    return NULL;
  return fopen(expanded, spec);
}

/*
   Expanding Unix filenames
   Unix Sucks
   Richard Kelsey Wed Jan 17 21:40:26 EST 1990
   Later modified by others who wish to remain anonymous
   "ps_" stands for "Pre-Scheme"

   Expands initial ~ and ~/ in string `name', leaving the result in `buffer'.
   `buffer_len' is the length of `buffer'.

   Note: strncpy(x, y, n) copies from y to x.
*/

char *
expand_file_name (char *name, char *buffer, int buffer_len)
{
# define USER_NAME_SIZE 256
  char *dir, *p, user_name[USER_NAME_SIZE];
  struct passwd *user_data;
  int dir_len, i;
  extern char *getenv();
  int name_len = strlen(name);

  dir = 0;

  if (name[0] == '~') {
    name++; name_len--;

    if (name[0] == '/' || name[0] == 0) {
      dir = getenv("HOME"); }

    else {
      for (i = 0, p = name; i < name_len && *p != '/'; i++, p++)
	if (i > (USER_NAME_SIZE - 2)) {
	  fprintf(stderr,
		  "\nexpand_file_name: user name longer than %d characters\n",
		  USER_NAME_SIZE - 3);
	  return(NULL); };
      strncpy(user_name, name, i);
      user_name[i] = 0;
      user_data = getpwnam(user_name);
      if (!user_data) {
	fprintf(stderr, "\nexpand_file_name: unknown user \"%s\"\n",
		user_name);
	return(NULL); };
      name_len -= i;
      name = p;
      dir = user_data->pw_dir; } }

  else if (name[0] == '$') {
    name++; name_len--;

    for (i = 0, p = name; i < name_len && *p != '/'; i++, p++)
      if (i > (USER_NAME_SIZE - 2)) {
	fprintf(stderr,
		"\nexpand_file_name: environment variable longer than %d characters\n",
		USER_NAME_SIZE - 3);
	return(NULL); };
    strncpy(user_name, name, i);
    user_name[i] = 0;

    name_len -= i;
    name = p;
    dir = getenv(user_name); }

  if (dir) {
    dir_len = strlen(dir);
    if ((name_len + dir_len + 1) > buffer_len) {
      fprintf(stderr, "\nexpand_file_name: supplied buffer is too small\n");
      return(NULL); };
    strncpy(buffer, dir, dir_len);
    strncpy(buffer + dir_len, name, name_len);
    buffer[name_len + dir_len] = 0; }

  else {
    if ((name_len + 1) > buffer_len) {
      fprintf(stderr, "\nexpand_file_name: supplied buffer is too small\n");
      return(NULL); };
    strncpy(buffer, name, name_len);
    buffer[name_len] = 0; }

  return(buffer);
}

/* test routine
main(argc, argv)
  int argc;
  char *argv[];
{
  char buffer[32];
  expand_file_name(argv[1], buffer, 32);
  printf("%s\n", buffer);
  return(0);
}
*/

/* ---------------------------------------- */
/* Timer functions, for the time instruction.
   gettimeofday() version courtesy Basile Starynkevitch.

   From: Jim.Rees@umich.edu
   Date: Sun, 26 Dec 93 16:06:08 EST

   In unix.c, the gettimeofday code is wrong.  ...
   I suggest the following fix, which will work on both sysV and bsd
   machines.  If you (or your compiler) are squeamish about passing
   too many parameters in to a system call, you might want to do it
   differently....
 */

#define TICKS_PER_SECOND 1000	/* should agree with ps_real_time() */

long
ps_real_time()
{
#if defined(HAVE_GETTIMEOFDAY)
  struct timeval tv;
  static struct timeval tv_orig;
  static int initp = 0;
  if (!initp) {
    gettimeofday(&tv_orig, NULL);
    initp = 1;
  };
  gettimeofday(&tv, NULL);
  return ((long)((tv.tv_sec - tv_orig.tv_sec)*TICKS_PER_SECOND
		 + (tv.tv_usec - tv_orig.tv_usec)/(1000000/TICKS_PER_SECOND)));
#elif defined(HAVE_FTIME)
  struct timeb tb;
  static struct timeb tb_origin;
  static int initp = 0;
  if (!initp) {
    ftime(&tb_origin);
    initp = 1;
  }
  ftime(&tb);
  return((long)((tb.time - tb_origin.time) * TICKS_PER_SECOND
		+ (tb.millitm / (1000 / TICKS_PER_SECOND))));
#else
  return (long)time(NULL) * TICKS_PER_SECOND;
#endif /*HAVE_GETTIMEOFDAY */
}

long
ps_run_time()
{
  struct tms time_buffer;
  static long clock_tick = 0;

  if (clock_tick == 0)
    clock_tick = sysconf(_SC_CLK_TCK); /* POSIX.1, POSIX.2 */
  times(&time_buffer);		/* On Sun, getrusage() would be better */
  return((long)(time_buffer.tms_utime * TICKS_PER_SECOND) / clock_tick);
}

long
ps_ticks_per_second()
{
  return TICKS_PER_SECOND;
}

long
ps_schedule_interrupt(long delay)
{
  sigaction(SIGALRM, &alarm_action, NULL);

#if defined(HAVE_SETITIMER)
  { struct itimerval new, old;

    delay = delay * (1000000 / TICKS_PER_SECOND);
    new.it_value.tv_sec = delay / 1000000;
    new.it_value.tv_usec = delay % 1000000;
    new.it_interval.tv_sec = 0;
    new.it_interval.tv_usec = 0;
    if (0 == setitimer(ITIMER_REAL, &new, &old))
      return (old.it_value.tv_usec + 1000000 * old.it_value.tv_sec)
	/ (1000000 / TICKS_PER_SECOND);
    else {
      perror("setitimer");
      return -1;
    }
  }
#else
  /* Round up to nearest second.  0 means cancel... */
  return alarm((delay + TICKS_PER_SECOND - 1) / TICKS_PER_SECOND)
	   * TICKS_PER_SECOND;
#endif
}

/*
** External symbol / foreign-function interface.
*******************************************************************************
** This code is ifdef'd. You must arrange it so that when it is handed a C
** identifier "foo" it looks up the corresponding a.out identifier, which can
** be "_foo" or "foo" or perhaps something else entirely.
**
** If USCORE is defined, then (get-external-name "main") will look up
** the a.out symbol "_main". If USCORE is undefined, the it simply looks
** up "main".
**
** lookup_external_name(name, loc):
** - On success, stores location in "loc" and returns 1.
** - On failure, returns 0.
*/

#if defined(_AIX)

/* The problem with AIX is threefold:
   - AIX throws away unused symbols during linking.
     Since the externals only get referenced at runtime, ld throws them out.
     This can, in theory, be turned off by the "nogc" option, but when
     that is used, all hell breaks lose.
   - AIX nlist lies: if you ask for "foobar", and there is a symbol "foo" in
     the symbol table before "foobar", it will give you the value for "foo".
   - AIX function pointers from the symbol table cannot be used directly:
     Rather, all jumps are indirect.  Therefore, the externals mechanism needs
     to set up an "activation record" which contains the actual pointer, followed
     by a toc value which is loaded into r2 in function activation.  I'm not sure what
     the third one is for.  Even then, an offset is involved which is calculated using
     the data of the "main" procedure. */

#include <filehdr.h>
#include <syms.h>
#include <ldfcn.h>

struct s_symbol_table {
    char *name;
    void *value;
    struct s_symbol_table *next;
};

static struct s_symbol_table *the_table = NULL;

#define MALLOC_TO(name, size) \
  if (((name) = malloc(size)) == NULL) { \
    fprintf(stderr, "Malloc error during external name lookup\n"); \
    return; \
  }

static void
fill_the_table(void)
{
  extern char *get_reloc_file();
  char *reloc_info_file;
  LDFILE *f;
  SYMENT entry;
  long i;
  struct s_symbol_table *cur_entry;

  reloc_info_file = get_reloc_file();

  if (reloc_info_file == NULL) {
    fprintf(stderr, "Error during external name lookup\n");
    return;
  }
  
  if ((f = ldopen(reloc_info_file, NULL)) == NULL) {
    fprintf(stderr, "Error during external name lookup\n");
    return;
  }

  if (!ldtbseek(f)) {
    ldclose(f);
    fprintf(stderr, "Error during external name lookup\n");
    return;
  }

  cur_entry = the_table;


  for (;;) {
    i = ldtbindex(f);
    if (!ldtbread(f, i, &entry))
      break;
    if (entry.n_sclass == C_EXT &&
	entry.n_scnum != N_UNDEF &&
	entry.n_scnum != N_DEBUG)
      {
	extern char *ldgetname(LDFILE *, SYMENT *);
	char *p = ldgetname(f, &entry);

	if (p != NULL && p[0] == '.') {
	  struct s_symbol_table *last_entry = cur_entry;

	  MALLOC_TO(cur_entry, sizeof(struct s_symbol_table));
	  MALLOC_TO(cur_entry->name, strlen(p));
	  strcpy(cur_entry->name, p+1); /* skip the dot */
	  cur_entry->value = (void *) entry.n_value;
	  if (!last_entry)
	    the_table = cur_entry;
	  else
	    last_entry->next = cur_entry;
	}
      }
  }

  if (cur_entry)
    cur_entry->next = NULL;
	
  ldclose(f);
}

static long
really_lookup_external_name(char *name)
{
  struct s_symbol_table *entry = the_table;

  while (entry) {
    if (!strcmp(entry->name, name))
      return((long) entry->value);
    entry = entry->next;
  }
  return(0);
}
      
long
lookup_external_name(char *name, long *location)
{
  long r;
  static long val_offset;
  extern int main();

  if (!the_table) {
    fill_the_table();
    val_offset =
      *((unsigned long *) ((void (*)()) main)) - really_lookup_external_name("main");
  }

  r = really_lookup_external_name(name);

  if (r) {
    unsigned long *activate;

    MALLOC_TO(activate, 3 * sizeof(unsigned long));
    memcpy(activate, (void *) main, 3 * sizeof(unsigned long));
    ((unsigned long *)activate)[0] = r + val_offset;
    *location = (long) activate;
    return(1);
  } else
    return(0);
}

#else /* i.e. #if !defined(_AIX) */

#if !defined(NLIST_HAS_N_NAME)
#define n_name	n_un.n_name
#endif

long
lookup_external_name(char *name, long *location)
{
  int namelen = strlen(name);
  char buf[20], *nm;

#if defined(HAVE_DLOPEN)
  extern int lookup_dlsym(char*, long*);
#elif defined(HAVE_NLIST)
  extern char *get_reloc_file();
  char *reloc_info_file;
  struct nlist name_list[2];
  int status;
#endif

  /* Compute the actual string being looked up. */
  /* Compute the length of the actual a.out symbol. */
#ifdef USCORE
  namelen++;
#endif

  nm = (namelen<20) ? buf : (char*) malloc(namelen+1);
  if (!nm) {
    fputs("Malloc error in lookup_external_name.\n", stderr);
    return(0);
  }

  /* Build the symbol in nm. */
#ifdef USCORE
  nm[0] = '_';
  strcpy(nm+1,name);
#else
  strcpy(nm,name);
#endif /*! HAVE_DLOPEN */
#if defined(HAVE_DLOPEN)
  return lookup_dlsym(nm, location);
#elif defined(HAVE_NLIST)

  reloc_info_file = get_reloc_file();

  if (reloc_info_file == NULL) {
    fprintf(stderr, "Error during external name lookup\n");
    return(0);
  }

  name_list[0].n_name = nm;
  name_list[1].n_name = 0;
  
  status = nlist(reloc_info_file, name_list);

  if (status != 0 || (name_list[0].n_value  == 0
		      && name_list[0].n_type == 0))
    return 0;
  else {
    *location = name_list[0].n_value;
    return 1;
  }
#else
  return 0;
#endif /*! HAVE_DLOPEN */
}

#endif /* !defined(AIX) */

extern char *object_file;   /* specified via a command line argument */
extern char *reloc_file;    /* dynamic loading will set this */

char *
get_reloc_file()
{
  if (reloc_file != NULL)
    return(reloc_file);
  if (object_file != NULL)
    return(object_file);
  else {
    fprintf(stderr, "Object file not specified on command line\n");
    return(NULL);
  }
}