diff options
Diffstat (limited to 'scm.c')
| -rw-r--r-- | scm.c | 437 |
1 files changed, 274 insertions, 163 deletions
@@ -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 |