/* 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@zurich.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 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 . Oh well, it can't hurt, can it? Oh yeah, this is Unix, of course it can... */ #include "sysdep.h" #include #include /* for getenv(), etc. (POSIX?/ANSI) */ #include /* for strncpy(), etc. (POSIX/ANSI) */ #include /* for getpwnam() (POSIX.1) */ #include /* for sysconf() (POSIX.1/.2)*/ #include /* for times() (POSIX.1) */ #include /* for sigaction() (POSIX.1) */ #if defined(HAVE_POSIX_TIME_H) # include /* RISC/OS + gcc lossage */ # define _XOPEN_SOURCE 1 #else # include #endif #if defined(HAVE_SETITIMER) || defined(HAVE_GETTIMEOFDAY) # include /* for struct itimerval, ITIMER_REAL (Sun) */ #endif #if defined(HAVE_SELECT) # include /* for FD_SET and friends (BSD) */ #if defined(HAVE_SYS_SELECT_H) # include #endif #endif #if defined(HAVE_SYS_TIMEB_H) # include /* for ftime() */ #endif #if defined(HAVE_NLIST_H) # include /* 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 */ /* Note that we turn off SIGPIPE interrupts in a funny way -- we don't ** set the handler to SIGIGN, we set it to a no-op function. This is so ** that when we exec() some other program, the handler will be reset to ** its default, rather than to SIGIGN. ** ** We don't use SIGPIPE, because all write() calls in scsh correctly check ** for error returns, and raise an error exception. Sleazy Unix C programs, ** however, need to get shot down when writing to a closed pipe or socket. ** -Olin 4/97 */ 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; } static RETSIGTYPE when_pipe_interrupt(sig, code, scp) int sig, code; struct sigcontext *scp; { 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 = when_pipe_interrupt; 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)) || defined(__CYGWIN32__) if (stream->_r) return 1; #else /* Add new cases here AND SEND THEM TO scheme-48@zurich.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); #ifndef __CYGWIN32__ timerclear(&timeout); #endif 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 #include #include 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 *, void *); 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(__hpux) #include lookup_external_name (char *name, long *location ) { int ret; shl_t shlh = PROG_HANDLE; *location = 0xdeadbeef; ret = shl_findsym (&shlh, name, TYPE_UNDEFINED, location); return (!ret); } #else /* i.e. #if !defined(__hpux) && !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 /*! USCORE */ #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(__hpux) */ #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); } }