summaryrefslogtreecommitdiffstats
path: root/scm.c
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:23 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:23 -0800
commit5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8 (patch)
tree9b744b9dbf39e716e56daa620e2f3041968caf19 /scm.c
downloadscm-5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8.tar.gz
scm-5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8.zip
Import Upstream version 4e6upstream/4e6
Diffstat (limited to 'scm.c')
-rw-r--r--scm.c940
1 files changed, 940 insertions, 0 deletions
diff --git a/scm.c b/scm.c
new file mode 100644
index 0000000..ce8e834
--- /dev/null
+++ b/scm.c
@@ -0,0 +1,940 @@
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "scm.c" top level and interrupt code.
+ Author: Aubrey Jaffer */
+
+#include <signal.h>
+#include "scm.h"
+#include "patchlvl.h"
+
+#ifdef __IBMC__
+# include <io.h>
+#endif
+
+#ifndef STDC_HEADERS
+ int alarm P((unsigned int));
+ int pause P((void));
+ unsigned int sleep P((unsigned int seconds));
+ char *getenv P((const char *name));
+ int system P((const char *));
+#endif
+#ifdef hpux
+# define const /**/
+#endif
+
+void final_repl P((void));
+void init_dynl P((void));
+void init_eval P((void));
+void init_features P((void));
+void init_io P((void));
+void init_ioext P((void));
+void init_repl P((int iverbose));
+void init_sc2 P((void));
+void init_scl P((void));
+void init_signals P((void));
+void init_subrs P((void));
+void init_tables P((void));
+void init_time P((void));
+void init_types P((void));
+void init_unif P((void));
+void init_ramap P((void));
+
+void init_banner()
+{
+ fputs("SCM version ", stderr);
+ fputs(SCMVERSION, stderr);
+ fputs(", Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996 \
+Free Software Foundation.\n\
+SCM comes with ABSOLUTELY NO WARRANTY; for details type `(terms)'.\n\
+This is free software, and you are welcome to redistribute it\n\
+under certain conditions; type `(terms)' for details.\n", stderr);
+}
+
+SCM scm_init_extensions()
+{
+#ifdef COMPILED_INITS
+ COMPILED_INITS; /* initialize statically linked add-ons */
+#endif
+ return UNSPECIFIED;
+}
+
+#if (__TURBOC__==1)
+# define signal ssignal /* Needed for TURBOC V1.0 */
+#endif
+
+/* SIGRETTYPE is the type that signal handlers return. See <signal.h>*/
+
+#ifdef RETSIGTYPE
+# define SIGRETTYPE RETSIGTYPE
+#else
+# ifdef STDC_HEADERS
+# if (__TURBOC__==1)
+# define SIGRETTYPE int
+# else
+# define SIGRETTYPE void
+# endif
+# else
+# ifdef linux
+# define SIGRETTYPE void
+# else
+# define SIGRETTYPE int
+# endif
+# endif
+#endif
+
+#ifdef vms
+# ifdef __GNUC__
+# define SIGRETTYPE int
+# endif
+#endif
+
+#ifdef SIGHUP
+static SIGRETTYPE hup_signal(sig)
+ int sig;
+{
+ signal(SIGHUP, hup_signal);
+ wta(UNDEFINED, (char *)HUP_SIGNAL, "");
+}
+#endif
+static SIGRETTYPE int_signal(sig)
+ int sig;
+{
+ sig = errno;
+ signal(SIGINT, int_signal);
+ if (ints_disabled) sig_deferred = 1;
+ else han_sig();
+ errno = sig;
+}
+
+/* If doesn't have SIGFPE, disable FLOATS for the rest of this file. */
+
+#ifndef SIGFPE
+# undef FLOATS
+#endif
+
+#ifdef FLOATS
+static SIGRETTYPE fpe_signal(sig)
+ int sig;
+{
+ signal(SIGFPE, fpe_signal);
+ wta(UNDEFINED, (char *)FPE_SIGNAL, "");
+}
+#endif
+#ifdef SIGBUS
+static SIGRETTYPE bus_signal(sig)
+ int sig;
+{
+ signal(SIGBUS, bus_signal);
+ wta(UNDEFINED, (char *)BUS_SIGNAL, "");
+}
+#endif
+#ifdef SIGSEGV /* AMIGA lacks! */
+static SIGRETTYPE segv_signal(sig)
+ int sig;
+{
+ signal(SIGSEGV, segv_signal);
+ wta(UNDEFINED, (char *)SEGV_SIGNAL, "");
+}
+#endif
+#ifdef atarist
+# undef SIGALRM /* only available via MiNT libs */
+#endif
+#ifdef GO32
+# undef SIGALRM
+#endif
+#ifdef __HIGHC__
+# undef SIGALRM
+#endif
+#ifdef SIGALRM
+static SIGRETTYPE alrm_signal(sig)
+ int sig;
+{
+ sig = errno;
+ signal(SIGALRM, alrm_signal);
+ if (ints_disabled) alrm_deferred = 1;
+ else han_alrm();
+ errno = sig;
+}
+static char s_alarm[] = "alarm";
+SCM lalarm(i)
+ SCM i;
+{
+ unsigned int j;
+ ASSERT(INUMP(i) && (INUM(i) >= 0), i, ARG1, s_alarm);
+ SYSCALL(j = alarm(INUM(i)););
+ return MAKINUM(j);
+}
+# ifndef AMIGA
+SCM l_pause()
+{
+ pause();
+ return UNSPECIFIED;
+}
+# endif
+#endif /* SIGALRM */
+
+#ifdef _WIN32
+# include <windows.h>
+#endif
+#ifndef AMIGA
+# ifndef _Windows
+static char s_sleep[] = "sleep";
+SCM l_sleep(i)
+ SCM i;
+{
+ unsigned int j = 0;
+ ASSERT(INUMP(i) && (INUM(i) >= 0), i, ARG1, s_sleep);
+# ifdef __HIGHC__
+ SYSCALL(sleep(INUM(i)););
+# else
+# ifdef _WIN32
+ Sleep(INUM(i));
+# else
+ SYSCALL(j = sleep(INUM(i)););
+# endif
+ return MAKINUM(j);
+}
+# endif
+# endif
+#endif
+
+#ifndef _WIN32
+# ifndef GO32
+# ifndef sun
+/* int raise P((int sig)); */
+static char s_raise[] = "raise";
+SCM l_raise(sig)
+ SCM sig;
+{
+ ASSERT(INUMP(sig), sig, ARG1, s_raise);
+# ifdef vms
+ return MAKINUM(gsignal((int)INUM(sig)));
+# else
+# ifndef __TURBOC__
+# ifdef STDC_HEADERS
+ return kill(getpid (), (int)INUM(sig)) ? BOOL_F : BOOL_T;
+# else
+ return raise((int)INUM(sig)) ? BOOL_F : BOOL_T;
+# endif
+# else
+ return raise((int)INUM(sig)) ? BOOL_F : BOOL_T;
+# endif
+# endif
+}
+# endif
+# endif
+#endif
+#ifdef TICKS
+unsigned int tick_count = 0, ticken = 0;
+SCM *loc_tick_signal;
+void tick_signal()
+{
+ if (ticken && NIMP(*loc_tick_signal)) {
+ ticken = 0;
+ apply(*loc_tick_signal, EOL, EOL);
+ }
+}
+static char s_ticks[] = "ticks";
+SCM lticks(i)
+ SCM i;
+{
+ SCM j = ticken ? tick_count : 0;
+ if (!UNBNDP(i)) ticken = tick_count = INUM(i);
+ return MAKINUM(j);
+}
+#endif
+
+#ifdef SIGHUP
+static SIGRETTYPE (*oldhup)();
+#endif
+static SIGRETTYPE (*oldint)();
+#ifdef FLOATS
+static SIGRETTYPE (*oldfpe)();
+#endif
+#ifdef SIGBUS
+static SIGRETTYPE (*oldbus)();
+#endif
+#ifdef SIGSEGV /* AMIGA lacks! */
+static SIGRETTYPE (*oldsegv)();
+#endif
+#ifdef SIGALRM
+static SIGRETTYPE (*oldalrm) ();
+#endif
+#ifdef SIGPIPE
+static SIGRETTYPE (*oldpipe) ();
+#endif
+
+int dumped = 0; /* Is this an invocation of unexec exe? */
+
+#ifdef SHORT_ALIGN
+typedef short STACKITEM;
+#else
+typedef long STACKITEM;
+#endif
+/* See scm.h for definition of P */
+void init_storage P((STACKITEM *stack_start_ptr, long init_heap_size));
+
+void init_scm( iverbose, buf0stdin, init_heap_size )
+ int iverbose;
+ int buf0stdin;
+ long init_heap_size;
+{
+ STACKITEM i;
+ if (2 <= iverbose) init_banner();
+ if (!dumped) {
+ init_types();
+ init_tables();
+ init_storage(&i, init_heap_size); /* CONT(rootcont)->stkbse gets set here */
+ if (buf0stdin) CAR(def_inp) |= BUF0;
+ init_features();
+ init_subrs();
+ init_io();
+ init_scl();
+ init_eval();
+ init_time();
+ init_repl( iverbose );
+ init_unif();
+ }}
+
+void init_signals()
+{
+ oldint = signal(SIGINT, int_signal);
+#ifdef SIGHUP
+ oldhup = signal(SIGHUP, hup_signal);
+#endif
+#ifdef FLOATS
+ oldfpe = signal(SIGFPE, fpe_signal);
+#endif
+#ifdef SIGBUS
+ oldbus = signal(SIGBUS, bus_signal);
+#endif
+#ifdef SIGSEGV /* AMIGA lacks! */
+ oldsegv = signal(SIGSEGV, segv_signal);
+#endif
+#ifdef SIGALRM
+ alarm(0); /* kill any pending ALRM interrupts */
+ oldalrm = signal(SIGALRM, alrm_signal);
+#endif
+#ifdef SIGPIPE
+ oldpipe = signal(SIGPIPE, SIG_IGN);
+#endif
+#ifdef ultrix
+ siginterrupt(SIGINT, 1);
+ siginterrupt(SIGALRM, 1);
+ siginterrupt(SIGHUP, 1);
+ siginterrupt(SIGPIPE, 1);
+#endif /* ultrix */
+}
+
+/* This is used in preparation for a possible fork(). Ignore all
+ signals before the fork so that child will catch only if it
+ establishes a handler */
+void ignore_signals()
+{
+#ifdef ultrix
+ siginterrupt(SIGINT, 0);
+ siginterrupt(SIGALRM, 0);
+ siginterrupt(SIGHUP, 0);
+ siginterrupt(SIGPIPE, 0);
+#endif /* ultrix */
+ signal(SIGINT, SIG_IGN);
+#ifdef SIGHUP
+ signal(SIGHUP, SIG_DFL);
+#endif
+#ifdef FLOATS
+ signal(SIGFPE, SIG_DFL);
+#endif
+#ifdef SIGBUS
+ signal(SIGBUS, SIG_DFL);
+#endif
+#ifdef SIGSEGV /* AMIGA lacks! */
+ signal(SIGSEGV, SIG_DFL);
+#endif
+ /* Some documentation claims that ALRMs are cleared accross forks.
+ If this is not always true then the value returned by alarm(0)
+ will have to be saved and unignore_signals() will have to
+ reinstate it. */
+ /* This code should be neccessary only if the forked process calls
+ alarm() without establishing a handler:
+#ifdef SIGALRM
+ oldalrm = signal(SIGALRM, SIG_DFL);
+#endif */
+ /* These flushes are per warning in man page on fork(). */
+ fflush(stdout);
+ fflush(stderr);
+}
+
+void unignore_signals()
+{
+ signal(SIGINT, int_signal);
+#ifdef SIGHUP
+ signal(SIGHUP, hup_signal);
+#endif
+#ifdef FLOATS
+ signal(SIGFPE, fpe_signal);
+#endif
+#ifdef SIGBUS
+ signal(SIGBUS, bus_signal);
+#endif
+#ifdef SIGSEGV /* AMIGA lacks! */
+ signal(SIGSEGV, segv_signal);
+#endif
+#ifdef SIGALRM
+ signal(SIGALRM, alrm_signal);
+#endif
+#ifdef ultrix
+ siginterrupt(SIGINT, 1);
+ siginterrupt(SIGALRM, 1);
+ siginterrupt(SIGHUP, 1);
+ siginterrupt(SIGPIPE, 1);
+#endif /* ultrix */
+}
+
+void restore_signals()
+{
+#ifdef ultrix
+ siginterrupt(SIGINT, 0);
+ siginterrupt(SIGALRM, 0);
+ siginterrupt(SIGHUP, 0);
+ siginterrupt(SIGPIPE, 0);
+#endif /* ultrix */
+ signal(SIGINT, oldint);
+#ifdef SIGHUP
+ signal(SIGHUP, oldhup);
+#endif
+#ifdef FLOATS
+ signal(SIGFPE, oldfpe);
+#endif
+#ifdef SIGBUS
+ signal(SIGBUS, oldbus);
+#endif
+#ifdef SIGSEGV /* AMIGA lacks! */
+ signal(SIGSEGV, oldsegv);
+#endif
+#ifdef SIGPIPE
+ signal(SIGPIPE, oldpipe);
+#endif
+#ifdef SIGALRM
+ alarm(0); /* kill any pending ALRM interrupts */
+ signal(SIGALRM, oldalrm);
+#endif
+}
+
+int run_scm(argc, argv, iverbose, buf0stdin, initpath)
+ int argc;
+ char **argv;
+ int iverbose;
+ int buf0stdin;
+ char *initpath;
+{
+ SCM i;
+ do {
+ i = 0L;
+ if ((2 <= argc) && argv[1] && (0==strncmp("-a", argv[1], 2))) {
+ char *str = (0==argv[1][2] && 3 <= argc && argv[2]) ?argv[2]:&argv[1][2];
+ do {
+ switch (*str) {
+ case DIGITS:
+ i = i * 10 + (*str - '0');
+ if (i <= 10000L) continue; /* the size limit should match Init.scm */
+ default:
+ i = 0L;
+ }
+ break;
+ } while (* ++str);
+ }
+ init_scm(iverbose, buf0stdin, (0 >= i) ? 0L : 1024L * i); /* size in Kb */
+ progargs = EOL;
+ progargs = makfromstrs(argc, argv);
+
+ if (!dumped) {
+#ifdef HAVE_DYNL
+ init_dynl();
+#endif
+#ifdef INITS
+ INITS; /* call initialization of extension files */
+#endif
+ }
+ init_signals();
+ i = repl_driver(initpath);
+ restore_signals();
+#ifdef TICKS
+ ticken = 0;
+#endif
+#ifdef FINALS
+ FINALS; /* call shutdown of extensions files */
+#endif /* for compatability with older modules */
+ /* call finalization of user extensions */
+ while (num_finals--) (finals[num_finals])();
+ final_repl();
+ free_storage(); /* free all allocated memory */
+ if (i) break;
+ dumped = 0;
+ if (2 <= iverbose) fputs(";RESTART\n", stderr);
+ } while (!0);
+ if (2 <= iverbose) fputs(";EXIT\n", stderr);
+ fflush(stderr);
+ return (int)INUM(i);
+}
+
+#ifdef vms
+# define SYSTNAME "vms"
+#endif
+#ifdef unix
+# define DIRSEP "/"
+# ifndef MSDOS /* DJGPP defines both */
+# define SYSTNAME "unix"
+# endif
+#endif
+#ifdef MWC
+# define SYSTNAME "coherent"
+# define DIRSEP "/"
+#endif
+#ifdef _Windows
+# define SYSTNAME "windows"
+# define DIRSEP "\\"
+#else
+# ifdef MSDOS
+# define SYSTNAME "ms-dos"
+# ifndef unix
+# define DIRSEP "\\"
+# endif
+# endif
+#endif
+#ifdef __EMX__
+# define SYSTNAME "os/2"
+# define DIRSEP "\\"
+#endif
+#ifdef __IBMC__
+# define SYSTNAME "os/2"
+# define DIRSEP "\\"
+#endif
+#ifdef THINK_C
+# define SYSTNAME "thinkc"
+# define DIRSEP ":"
+#endif
+#ifdef AMIGA
+# define SYSTNAME "amiga"
+# define DIRSEP "/"
+#endif
+#ifdef atarist
+# define SYSTNAME "atarist"
+# define DIRSEP "\\"
+#endif
+#ifdef mach
+# define SYSTNAME "mach"
+# define DIRSEP "/"
+#endif
+#ifdef ARM_ULIB
+# define SYSTNAME "acorn"
+#endif
+#ifdef nosve
+# define INIT_FILE_NAME "Init_scm";
+# define DIRSEP "."
+#endif
+
+SCM softtype()
+{
+#ifdef nosve
+ return CAR(intern("nosve", 5));
+#else
+ return CAR(intern(SYSTNAME, sizeof SYSTNAME/sizeof(char) -1));
+#endif
+}
+
+/* Concatentate str2 onto str1 at position n and return concatenated
+ string if file exists; 0 otherwise. */
+
+char *scm_cat_path(str1, str2, n)
+ char *str1;
+ const char *str2;
+ long n;
+{
+ if (!n) n = strlen(str2);
+ if (str1)
+ {
+ long len = strlen(str1);
+ str1 = (char *)realloc(str1, (sizet)(len + n + 1));
+ if (!str1) return 0;
+ strncat(str1 + len, str2, n);
+ return str1;
+ }
+ str1 = (char *)malloc((sizet)(n + 1));
+ if (!str1) return 0;
+ str1[0] = 0;
+ strncat(str1, str2, n);
+ return str1;
+}
+
+char *scm_try_path(path)
+ char *path;
+{
+ FILE *f;
+ /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
+ if (!path) return 0;
+ SYSCALL(f = fopen(path, "r"););
+ if (f) {
+ fclose(f);
+ return path;
+ }
+ free(path);
+ return 0;
+}
+
+char *scm_sep_init_try(path, sep, initname)
+ char *path;
+ const char *sep, *initname;
+{
+ if (path) path = scm_cat_path(path, sep, 0L);
+ if (path) path = scm_cat_path(path, initname, 0L);
+ return scm_try_path(path);
+}
+
+#ifdef MSDOS
+char *dld_find_executable(file)
+ const char *file;
+{
+ return scm_cat_path(0L, file, 0L);
+}
+#endif
+
+#ifndef INIT_FILE_NAME
+# define INIT_FILE_NAME "Init.scm"
+#endif
+#ifndef DIRSEP
+# define DIRSEP "/"
+#endif
+#ifndef GENERIC_NAME
+# define GENERIC_NAME "scm"
+#endif
+
+/* Given dld_find_executable()'s best guess for the pathname of this
+ executable, find (and verify the existence of) initname in the
+ implementation-vicinity of this program. Returns a newly allocated
+ string if successful, 0 if not */
+
+char *scm_find_impl_file(exec_path, generic_name, initname, sep)
+ char *exec_path;
+ const char *generic_name, *initname, *sep;
+{
+ char *sepptr = strrchr(exec_path, sep[0]);
+ char *extptr = exec_path + strlen(exec_path);
+ char *path = 0;
+ if (sepptr) {
+ long sepind = sepptr - exec_path + 1L;
+
+ /* In case exec_path is in the source directory, look first in
+ exec_path's directory. */
+ path = scm_cat_path(0L, exec_path, sepind - 1L);
+ path = scm_sep_init_try(path, sep, initname);
+ if (path) return path;
+
+#ifdef MSDOS
+ if (!strcmp(extptr - 4, ".exe") || !strcmp(extptr - 4, ".com") ||
+ !strcmp(extptr - 4, ".EXE") || !strcmp(extptr - 4, ".COM"))
+ extptr = extptr - 4;
+#endif
+
+ if (generic_name &&
+ !strncmp(exec_path + sepind, generic_name, extptr - exec_path))
+ generic_name = 0;
+
+ /* If exec_path is in directory "exe" or "bin": */
+ path = scm_cat_path(0L, exec_path, sepind - 1L);
+ sepptr = path + sepind - 4;
+ if (!strcmp(sepptr, "exe") || !strcmp(sepptr, "bin") ||
+ !strcmp(sepptr, "EXE") || !strcmp(sepptr, "BIN")) {
+ char *peer;
+
+ /* Look for initname in peer directory "lib". */
+ if (path) {
+ strncpy(sepptr, "lib", 3);
+ path = scm_sep_init_try(path, sep, initname);
+ if (path) return path;
+ }
+
+ /* Look for initname in peer directories "lib" and "src" in
+ subdirectory with the name of the executable (sans any type
+ extension like .EXE). */
+ for(peer="lib";!0;peer="src") {
+ path = scm_cat_path(0L, exec_path, extptr - exec_path + 0L);
+ if (path) {
+ strncpy(path + sepind - 4, peer, 3);
+ path[extptr - exec_path] = 0;
+ path = scm_sep_init_try(path, sep, initname);
+ if (path) return path;
+ }
+ if (!strcmp(peer,"src")) break;
+ }
+
+ if (generic_name) {
+
+ /* Look for initname in peer directories "lib" and "src" in
+ subdirectory with the generic name. */
+ for(peer="lib";!0;peer="src") {
+ path = scm_cat_path(0L, exec_path, sepind);
+ if (path) {
+ strncpy(path + sepind - 4, "lib", 3);
+ path = scm_cat_path(path, generic_name, 0L);
+ path = scm_sep_init_try(path, sep, initname);
+ if (path) return path;
+ }
+ if (!strcmp(peer,"src")) break;
+ }}}
+
+#ifdef MSDOS
+ if (strlen(extptr)) {
+ /* If exec_path has type extension, look in a subdirectory with
+ the name of the executable sans the executable file's type
+ extension. */
+ path = scm_cat_path(0L, exec_path, extptr - exec_path + 0L);
+ path = scm_sep_init_try(path, sep, initname);
+ if (path) return path;
+
+ if (generic_name) {
+
+ /* Also look in generic_name subdirectory. */
+ path = scm_cat_path(0L, exec_path, sepind);
+ if (path) path = scm_cat_path(path, generic_name, 0L);
+ path = scm_sep_init_try(path, sep, initname);
+ if (path) return path;
+ }}
+#endif
+ }
+ else {
+
+ /* We don't have a parse-able exec_path. The only path to try is
+ just initname. */
+ path = scm_cat_path(0L, initname, 0L);
+ if (path) path = scm_try_path(path);
+ if (path) return path;
+ }
+ return 0;
+}
+
+#ifndef RTL
+char *execpath = 0;
+int main( argc, argv )
+ int argc;
+ char **argv;
+{
+ int retval, buf0stdin = 0;
+ char *getenvpath, *implpath = 0;
+
+# ifndef nosve
+ getenvpath = getenv("SCM_INIT_PATH");
+ if (getenvpath) implpath = scm_cat_path(0L, getenvpath, 0L);
+ if (implpath) {
+
+ /* The value of the environment variable supersedes other
+ locations, as long as the file exists. */
+ implpath = scm_try_path(implpath);
+ if (!implpath) {
+ fputs("Value of SCM_INIT_PATH (=\"", stderr);
+ fputs(getenvpath, stderr);
+ fputs("\") not found; Trying elsewhere\n", stderr);
+ }
+ }
+# endif
+
+ if (!implpath) {
+ execpath = dld_find_executable(argv[0]);
+ if (execpath) {
+ /* fprintf(stderr, "dld found exe \"%s\"\n", execpath); fflush(stderr); */
+ implpath = scm_find_impl_file(execpath,
+ GENERIC_NAME, INIT_FILE_NAME, DIRSEP);
+ /* fprintf(stderr, "scm_find_impl_file returned \"%s\"\n", implpath); fflush(stderr); */
+ }
+# ifdef IMPLINIT
+ if (!implpath) implpath = scm_cat_path(0L, IMPLINIT, 0L);
+# endif
+ }
+# ifndef GO32
+ if (isatty(fileno(stdin))) {
+ buf0stdin = !0; /* stdin gets marked BUF0 in init_scm() */
+# ifndef NOSETBUF
+# ifndef _DCC
+# ifndef ultrix
+# ifndef __WATCOMC__
+# ifndef THINK_C
+# if (__TURBOC__ != 1)
+# ifndef _Windows
+ setbuf(stdin, 0); /* Often setbuf isn't actually required */
+# endif
+# endif
+# endif
+# endif
+# endif
+# endif
+ }
+# endif
+# endif
+ retval = run_scm(argc, argv,
+ (isatty(fileno(stdin)) && isatty(fileno(stdout)))
+ ? (argc <= 1) ? 2 : 1 : 0,
+ buf0stdin,
+ implpath ? implpath : "");
+ if (implpath) free(implpath);
+ if (execpath) free(execpath);
+ return retval;
+}
+#endif
+
+#ifndef _Windows
+char s_system[] = "system";
+SCM lsystem(cmd)
+ SCM cmd;
+{
+ ASSERT(NIMP(cmd) && STRINGP(cmd), cmd, ARG1, s_system);
+ ignore_signals();
+# ifdef AZTEC_C
+ cmd = MAKINUM(Execute(CHARS(cmd), 0, 0));
+# else
+ cmd = MAKINUM(0L+system(CHARS(cmd)));
+# endif
+ unignore_signals();
+ return cmd;
+}
+#endif
+
+char s_getenv[] = "getenv";
+char *getenv();
+SCM lgetenv(nam)
+ SCM nam;
+{
+ char *val;
+ ASSERT(NIMP(nam) && STRINGP(nam), nam, ARG1, s_getenv);
+ val = getenv(CHARS(nam));
+ if (!val) return BOOL_F;
+ return makfrom0str(val);
+}
+
+#ifdef vms
+# include <descrip.h>
+# include <ssdef.h>
+char s_ed[] = "ed";
+SCM ed(fname)
+ SCM fname;
+{
+ struct dsc$descriptor_s d;
+ ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_ed);
+ d.dsc$b_dtype = DSC$K_DTYPE_T;
+ d.dsc$b_class = DSC$K_CLASS_S;
+ d.dsc$w_length = LENGTH(fname);
+ d.dsc$a_pointer = CHARS(fname);
+ /* I don't know what VMS does with signal handlers across the
+ edt$edit call. */
+ ignore_signals();
+ edt$edit(&d);
+ unignore_signals();
+ return fname;
+}
+SCM vms_debug()
+{
+ lib$signal(SS$_DEBUG);
+ return UNSPECIFIED;
+}
+#endif
+
+static iproc subr0s[] = {
+ {"software-type", softtype},
+ {"scm_init_extensions", scm_init_extensions},
+#ifdef vms
+ {"vms-debug", vms_debug},
+#endif
+#ifdef SIGALRM
+# ifndef AMIGA
+ {"pause", l_pause},
+# endif
+#endif
+ {0, 0}};
+static iproc subr1s[] = {
+ {s_getenv, lgetenv},
+#ifndef _Windows
+ {s_system, lsystem},
+#endif
+#ifdef vms
+ {s_ed, ed},
+#endif
+#ifdef SIGALRM
+ {s_alarm, lalarm},
+#endif
+#ifndef AMIGA
+# ifndef _Windows
+ {s_sleep, l_sleep},
+# endif
+#endif
+#ifndef GO32
+# ifndef sun
+# ifndef _WIN32
+ {s_raise, l_raise},
+# endif
+# endif
+#endif
+ {0, 0}};
+
+SCM *loc_features;
+void add_feature(str)
+ char* str;
+{
+ *loc_features = cons(CAR(intern(str, strlen(str))), *loc_features);
+}
+void init_features()
+{
+ loc_features = &CDR(sysintern("*features*", EOL));
+ init_iprocs(subr0s, tc7_subr_0);
+ init_iprocs(subr1s, tc7_subr_1);
+#ifdef TICKS
+ loc_tick_signal = &CDR(sysintern("ticks-interrupt", UNDEFINED));
+ make_subr(s_ticks, tc7_subr_1o, lticks);
+#endif
+#ifdef RECKLESS
+ add_feature("reckless");
+#endif
+#ifndef _Windows
+ add_feature(s_system);
+#endif
+#ifdef vms
+ add_feature(s_ed);
+#endif
+ sysintern("*scm-version*", makfrom0str(SCMVERSION));
+}