summaryrefslogtreecommitdiffstats
path: root/scm.c
diff options
context:
space:
mode:
authorDavid N. Welton <davidw@efn.org>1998-12-11 20:21:49 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commita47af30d2f0e96afcd1f14b1984575c359faa3d6 (patch)
tree2ed08ce2d757f917de7c3c7c04fd7e309f454c83 /scm.c
parentf64b2806c1d66a1341bb8b1491f384169ab1d65f (diff)
parentdb04688faa20f3576257c0fe41752ec435beab9a (diff)
downloadscm-a47af30d2f0e96afcd1f14b1984575c359faa3d6.tar.gz
scm-a47af30d2f0e96afcd1f14b1984575c359faa3d6.zip
Import Debian changes 5c3-5debian/5c3-5
scm (5c3-5) frozen unstable; urgency=low * debian/rules chmod +x's bld.scm. Fixes #30521. scm (5c3-4) frozen unstable; urgency=low * Made bld.scm executable. Fixes #29578. scm (5c3-3) frozen unstable; urgency=low * -nw * Fixes #16762. * Fixes #18163. * Fixes #18164. * Fixes #23743. * Fixes #24098. * Fixes #24099. * Fixes #24547. scm (5c3-2) frozen unstable; urgency=low * Re-uploading for slink freeze. scm (5c3-1) unstable; urgency=low * New upstream version.
Diffstat (limited to 'scm.c')
-rw-r--r--scm.c437
1 files changed, 274 insertions, 163 deletions
diff --git a/scm.c b/scm.c
index 5f305a8..fc26a6f 100644
--- a/scm.c
+++ b/scm.c
@@ -64,20 +64,28 @@
void final_repl P((void));
void init_dynl P((void));
+void init_edline P((void));
void init_eval P((void));
void init_features P((void));
+void init_gsubr P((void));
void init_io P((void));
void init_ioext P((void));
+void init_posix P((void));
+void init_ramap P((void));
+void init_record P((void));
+void init_rgx P((void));
+void init_rope 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_socket 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 reset_time P((void));
void init_banner()
{
@@ -128,22 +136,69 @@ SCM scm_init_extensions()
# endif
#endif
-#ifdef SIGHUP
-static SIGRETTYPE hup_signal(sig)
+#define SIGNAL_BASE HUP_SIGNAL
+#define NUM_SIGNALS (sizeof(sigdesc)/sizeof(sigdesc[0]))
+/* PROF_SIGNAL appears below because it is the last signal
+ defined in scm.h and in errmsgs in repl.c */
+static struct {
+ int signo; SIGRETTYPE (*osig)(); SIGRETTYPE (*nsig)();
+} sigdesc[PROF_SIGNAL - SIGNAL_BASE + 1];
+void process_signals()
+{
+ int i = NUM_SIGNALS;
+ unsigned long mask = (1L << (i-1));
+ if (output_deferred) {
+ output_deferred = 0;
+ lflush(sys_errp);
+ }
+ if (SIG_deferred)
+ while (i--) {
+ if (SIG_deferred & mask) {
+ SIG_deferred &= ~mask;
+ handle_it(i + SIGNAL_BASE);
+ }
+ mask >>= 1;
+ }
+ deferred_proc = 0;
+}
+static char s_unksig[] = "unknown signal";
+static SIGRETTYPE err_signal(sig)
int sig;
{
- signal(SIGHUP, hup_signal);
- wta(UNDEFINED, (char *)HUP_SIGNAL, "");
+ int i = NUM_SIGNALS;
+ signal(sig, err_signal);
+ while (i--)
+ if (sig == sigdesc[i].signo) break;
+ wta(MAKINUM(sig), (i < 0 ? s_unksig : (char *)(i + SIGNAL_BASE)), "");
}
-#endif
-static SIGRETTYPE int_signal(sig)
+static SIGRETTYPE scmable_signal(sig)
int sig;
{
- sig = errno;
- signal(SIGINT, int_signal);
- if (ints_disabled) sig_deferred = 1;
- else han_sig();
- errno = sig;
+ int oerr = errno;
+ int i = NUM_SIGNALS;
+ while (i--)
+ if (sig == sigdesc[i].signo) break;
+ ASSERT(i >= 0, MAKINUM(sig), s_unksig, "");
+ signal(sig, scmable_signal);
+ if (ints_disabled) {
+ deferred_proc = process_signals;
+ SIG_deferred |= (1L << i);
+ }
+ else {
+#ifdef SIG_UNBLOCK
+ sigset_t set;
+ sigemptyset(&set);
+ sigaddset(&set, sig);
+ sigprocmask(SIG_UNBLOCK, &set, 0);
+#endif
+ SIG_deferred &= ~(1L << i);
+ i += SIGNAL_BASE;
+ if (i != handle_it(i)) {
+ errno = oerr;
+ wta(UNDEFINED, (char *)i, "");
+ }
+ }
+ errno = oerr;
}
/* If doesn't have SIGFPE, disable FLOATS for the rest of this file. */
@@ -152,29 +207,8 @@ static SIGRETTYPE int_signal(sig)
# 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, "");
-}
+#ifdef macintosh
+# undef SIGALRM
#endif
#ifdef atarist
# undef SIGALRM /* only available via MiNT libs */
@@ -186,15 +220,6 @@ static SIGRETTYPE segv_signal(sig)
# 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;
@@ -204,12 +229,38 @@ SCM lalarm(i)
SYSCALL(j = alarm(INUM(i)););
return MAKINUM(j);
}
+# ifdef SIGPROF
+# include <sys/time.h>
+static char s_proftimer[] = "profile-timer";
+SCM scm_proftimer(interval)
+ SCM interval;
+{
+ struct itimerval tval, oval;
+ int w;
+ if (UNBNDP(interval))
+ SYSCALL(w = getitimer(ITIMER_PROF, &oval););
+ else {
+ if (BOOL_F==interval) interval = INUM0;
+ ASSERT(INUMP(interval), interval, ARG2, s_proftimer);
+ tval.it_interval.tv_sec = INUM(interval) / 1000;
+ tval.it_interval.tv_usec = (INUM(interval) % 1000)*1000;
+ tval.it_value.tv_sec = tval.it_interval.tv_sec;
+ tval.it_value.tv_usec = tval.it_interval.tv_usec;
+ SYSCALL(w = setitimer(ITIMER_PROF, &tval, &oval););
+ }
+ if (w) return BOOL_F;
+ return MAKINUM(oval.it_interval.tv_usec/1000 +
+ oval.it_interval.tv_sec*1000);
+}
+# endif
# ifndef AMIGA
+# ifndef __CYGWIN32__
SCM l_pause()
{
pause();
return UNSPECIFIED;
}
+# endif
# endif
#endif /* SIGALRM */
@@ -232,8 +283,8 @@ SCM l_sleep(i)
# else
SYSCALL(j = sleep(INUM(i)););
# endif
- return MAKINUM(j);
# endif
+ return MAKINUM(j);
}
# endif
#endif
@@ -241,26 +292,32 @@ SCM l_sleep(i)
#ifndef _WIN32
# ifndef GO32
# ifndef sun
+# ifndef THINK_C
/* 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
+# ifdef vms
return MAKINUM(gsignal((int)INUM(sig)));
-# else
-# ifndef __TURBOC__
-# ifdef STDC_HEADERS
+# else
+# ifndef __TURBOC__
+# ifdef STDC_HEADERS
+# ifndef __MWERKS__
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
# 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
#endif
@@ -284,27 +341,14 @@ SCM lticks(i)
}
#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? */
+#ifndef LACK_SBRK
+long scm_init_brk, scm_dumped_brk;
+#endif
#ifdef SHORT_ALIGN
typedef short STACKITEM;
@@ -325,7 +369,10 @@ void init_scm( iverbose, buf0stdin, init_heap_size )
init_types();
init_tables();
init_storage(&i, init_heap_size); /* CONT(rootcont)->stkbse gets set here */
- if (buf0stdin) CAR(def_inp) |= BUF0;
+ }
+ if (buf0stdin) CAR(def_inp) |= BUF0;
+ else CAR(def_inp) &= ~BUF0;
+ if (!dumped) {
init_features();
init_subrs();
init_io();
@@ -334,26 +381,44 @@ void init_scm( iverbose, buf0stdin, init_heap_size )
init_time();
init_repl( iverbose );
init_unif();
- }}
+ }
+ else {
+ reset_time();
+ }
+}
+static void init_sig1(scm_err, signo, handler)
+ int scm_err;
+ int signo;
+ SIGRETTYPE (*handler)();
+{
+ int i = scm_err - SIGNAL_BASE;
+ ASSERT(i < NUM_SIGNALS, MAKINUM(i), OUTOFRANGE, "init_sig1");
+ sigdesc[i].signo = signo;
+ sigdesc[i].nsig = handler;
+ sigdesc[i].osig = signal(signo, handler);
+}
void init_signals()
{
- oldint = signal(SIGINT, int_signal);
+ init_sig1(INT_SIGNAL, SIGINT, scmable_signal);
#ifdef SIGHUP
- oldhup = signal(SIGHUP, hup_signal);
+ init_sig1(HUP_SIGNAL, SIGHUP, scmable_signal);
#endif
#ifdef FLOATS
- oldfpe = signal(SIGFPE, fpe_signal);
+ init_sig1(FPE_SIGNAL, SIGFPE, err_signal);
#endif
#ifdef SIGBUS
- oldbus = signal(SIGBUS, bus_signal);
+ init_sig1(BUS_SIGNAL, SIGBUS, err_signal);
#endif
#ifdef SIGSEGV /* AMIGA lacks! */
- oldsegv = signal(SIGSEGV, segv_signal);
+ init_sig1(SEGV_SIGNAL, SIGSEGV, err_signal);
#endif
#ifdef SIGALRM
alarm(0); /* kill any pending ALRM interrupts */
- oldalrm = signal(SIGALRM, alrm_signal);
+ init_sig1(ALRM_SIGNAL, SIGALRM, scmable_signal);
+# ifdef SIGPROF
+ init_sig1(PROF_SIGNAL, SIGPROF, scmable_signal);
+# endif
#endif
#ifdef SIGPIPE
oldpipe = signal(SIGPIPE, SIG_IGN);
@@ -365,63 +430,48 @@ void init_signals()
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()
{
+ int i = NUM_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
+ while (i--)
+ if (sigdesc[i].signo)
+ signal(sigdesc[i].signo, SIG_DFL);
/* 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:
+ /* This code should be necessary only if the forked process calls
+ alarm() without establishing a handler: */
#ifdef SIGALRM
- oldalrm = signal(SIGALRM, SIG_DFL);
-#endif */
+ /* oldalrm = signal(SIGALRM, SIG_DFL); */
+#endif
/* These flushes are per warning in man page on fork(). */
fflush(stdout);
fflush(stderr);
+#ifdef SIG_UNBLOCK
+ {
+ sigset_t set;
+ sigfillset(&set);
+ sigprocmask(SIG_UNBLOCK, &set, 0);
+ }
+#endif
}
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
+ int i = NUM_SIGNALS;
+ while (i--)
+ if (sigdesc[i].signo)
+ signal(sigdesc[i].signo, sigdesc[i].nsig);
#ifdef ultrix
siginterrupt(SIGINT, 1);
siginterrupt(SIGALRM, 1);
@@ -432,34 +482,26 @@ void unignore_signals()
void restore_signals()
{
+ int i = NUM_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);
+# ifdef SIGPROF
+ scm_proftimer(BOOL_F); /* Turn off interval timer interrupt */
+# endif
+#endif
+ while (i--)
+ if (sigdesc[i].signo)
+ signal(sigdesc[i].signo, sigdesc[i].osig);
+#ifdef SIGPIPE
+ oldpipe = signal(SIGPIPE, SIG_IGN);
#endif
}
-
int run_scm(argc, argv, iverbose, buf0stdin, initpath)
int argc;
char **argv;
@@ -487,10 +529,12 @@ int run_scm(argc, argv, iverbose, buf0stdin, initpath)
progargs = EOL;
progargs = makfromstrs(argc, argv);
- if (!dumped) {
#ifdef HAVE_DYNL
- init_dynl();
+ /* init_dynl() must check dumped to avoid redefining subrs */
+ init_dynl();
#endif
+
+ if (!dumped) {
#ifdef INITS
INITS; /* call initialization of extension files */
#endif
@@ -517,6 +561,10 @@ int run_scm(argc, argv, iverbose, buf0stdin, initpath)
return (int)INUM(i);
}
+#ifdef __CYGWIN32__
+# define SYSTNAME "unix"
+# define DIRSEP "/"
+#endif
#ifdef vms
# define SYSTNAME "vms"
#endif
@@ -553,6 +601,10 @@ int run_scm(argc, argv, iverbose, buf0stdin, initpath)
# define SYSTNAME "thinkc"
# define DIRSEP ":"
#endif
+#ifdef __MWERKS__
+# define SYSTNAME "macos"
+# define DIRSEP ":"
+#endif
#ifdef AMIGA
# define SYSTNAME "amiga"
# define DIRSEP "/"
@@ -569,7 +621,6 @@ int run_scm(argc, argv, iverbose, buf0stdin, initpath)
# define SYSTNAME "acorn"
#endif
#ifdef nosve
-# define INIT_FILE_NAME "Init_scm";
# define DIRSEP "."
#endif
@@ -582,11 +633,14 @@ SCM softtype()
#endif
}
+/* The argument giving the location of a script file, or NULL. */
+static char *script_arg = 0;
+/* The original argv[0], used to find executable. */
+static char *arg0 = 0;
+char *execpath = 0;
+
#ifndef RTL
-# ifndef INIT_FILE_NAME
-# define INIT_FILE_NAME "Init.scm"
-# endif
# ifndef DIRSEP
# define DIRSEP "/"
# endif
@@ -594,53 +648,73 @@ SCM softtype()
# define GENERIC_NAME "scm"
# endif
-char *execpath = 0;
int main(argc, argv)
int argc;
char **argv;
{
int retval, buf0stdin = 0, nargc;
char *getenvpath, *implpath = 0, **nargv;
-
+# ifdef macintosh
+ char *foo[] = { "scm" };
+ if (argc == 0) {
+ argc = 1;
+ argv = foo;
+ }
+# endif
execpath = 0;
+ arg0 = argv[0];
+ /*{
+ char ** argvv = argv;
+ for (;*argvv;argvv++) {
+ fputs(*argvv,stderr);
+ fputs(" ",stderr);
+ }
+ fputs("\n",stderr);
+ }*/
+ /* The following applies only to SCSH style scripts, execpath
+ does not (cannot?) work properly for simple #! scripts */
if ((nargv = script_process_argv(argc, argv))) {
+ script_arg = argv[2];
nargc = script_count_argv(nargv);
-# ifdef unix
-# ifndef MSDOS
- execpath = script_find_executable(argv[2]);
-# endif
-# endif
}
else {
nargv = argv;
nargc = argc;
}
- /* fprintf(stderr, "execpath = %s\n", execpath); fflush(stderr); */
- if (!execpath) execpath = dld_find_executable(argv[0]);
-
+# ifndef LACK_SBRK
+ if (dumped)
+ scm_dumped_brk = (long)sbrk(0);
+ else
+ scm_init_brk = (long)sbrk(0);
+# endif
+ if (!dumped) {
# 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);
+ 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 (execpath && (!implpath)) {
- implpath = scm_find_impl_file(execpath,
- GENERIC_NAME, INIT_FILE_NAME, DIRSEP);
- /* fprintf(stderr, "scm_find_impl_file returned \"%s\"\n", implpath); fflush(stderr); */
- }
+ if (!implpath) {
+ execpath = scm_find_executable();
+ if (execpath) {
+ 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);
+ /* Should IMPLINIT somehow be visible if we've been dumped? */
+ 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() */
@@ -648,7 +722,7 @@ int main(argc, argv)
# ifndef _DCC
# ifndef ultrix
# ifndef __WATCOMC__
-# ifndef THINK_C
+# ifndef macintosh
# if (__TURBOC__ != 1)
# ifndef _Windows
setbuf(stdin, 0); /* Often setbuf isn't actually required */
@@ -673,6 +747,38 @@ int main(argc, argv)
}
#endif
+char *scm_find_executable()
+{
+ char *execpath = 0;
+#ifndef macintosh
+# ifdef unix
+# ifndef MSDOS
+ if (script_arg)
+ execpath = script_find_executable(script_arg);
+# endif
+# endif
+ if (!execpath && arg0) execpath = dld_find_executable(arg0);
+ /* fprintf(stderr, "scm_find_executable: execpath = %s\n", execpath); fflush(stderr); */
+#endif
+ return execpath;
+}
+
+/* Initialized in repl.c */
+char s_scm_find_impl[] = "find-init-file";
+SCM scm_find_impl(execpath)
+ SCM execpath;
+{
+ SCM res;
+ char *implpath = 0;
+ ASSERT(NIMP(execpath) && STRINGP(execpath), execpath, ARG1, "find-init-file");
+ implpath = scm_find_impl_file(CHARS(execpath),
+ GENERIC_NAME, INIT_FILE_NAME, DIRSEP);
+ res = (implpath ? makfrom0str(implpath) : BOOL_F);
+ if (implpath) free(implpath);
+ return res;
+}
+
+
#ifndef _Windows
char s_system[] = "system";
SCM lsystem(cmd)
@@ -737,7 +843,9 @@ static iproc subr0s[] = {
#endif
#ifdef SIGALRM
# ifndef AMIGA
+# ifndef __CYGWIN32__
{"pause", l_pause},
+# endif
# endif
#endif
{0, 0}};
@@ -751,6 +859,9 @@ static iproc subr1s[] = {
#endif
#ifdef SIGALRM
{s_alarm, lalarm},
+# ifdef SIGPROF
+ {s_proftimer, scm_proftimer},
+# endif
#endif
#ifndef AMIGA
# ifndef _Windows