From 3278b75942bdbe706f7a0fba87729bb1e935b68b Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 5d2 --- scm.c | 455 ++++++++++++++++++++++++++++++------------------------------------ 1 file changed, 205 insertions(+), 250 deletions(-) (limited to 'scm.c') diff --git a/scm.c b/scm.c index fc26a6f..d5c1755 100644 --- a/scm.c +++ b/scm.c @@ -1,18 +1,18 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - * +/* Copyright (C) 1990-1999 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. + * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. @@ -36,10 +36,10 @@ * * 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. + * If you do not wish that, delete this exception notice. */ -/* "scm.c" top level and interrupt code. +/* "scm.c" Initialization and interrupt code. Author: Aubrey Jaffer */ #include @@ -50,6 +50,8 @@ # include #endif +/* See scm.h for definition of P */ + #ifndef STDC_HEADERS int alarm P((unsigned int)); int pause P((void)); @@ -60,9 +62,13 @@ # ifdef SVR4 # include # endif +# ifdef __amigados__ +# include +# endif #endif -void final_repl P((void)); +void init_sbrk P((void)); + void init_dynl P((void)); void init_edline P((void)); void init_eval P((void)); @@ -86,12 +92,11 @@ void init_time P((void)); void init_types P((void)); void init_unif P((void)); void reset_time P((void)); +void final_repl P((void)); void init_banner() { - fputs("SCM version ", stderr); - fputs(SCMVERSION, stderr); - fputs(", Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 \ + fputs("SCM version "SCMVERSION", Copyright (C) 1990-1999 \ 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\ @@ -101,9 +106,10 @@ under certain conditions; type `(terms)' for details.\n", stderr); SCM scm_init_extensions() { #ifdef COMPILED_INITS - COMPILED_INITS; /* initialize statically linked add-ons */ + COMPILED_INITS; /* initialize statically linked add-ons */ #endif - return UNSPECIFIED; + init_user_scm(); + return UNSPECIFIED; } #if (__TURBOC__==1) @@ -141,24 +147,25 @@ SCM scm_init_extensions() /* 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)(); + 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)); + int i, n; + unsigned long mask = 1L; 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; + for (n = 0; SIG_deferred && n < NUM_SIGNALS; n++) { + if (SIG_deferred & mask) { + i = n + SIGNAL_BASE; + SIG_deferred &= ~mask; + if (i != handle_it(i)) + wta(UNDEFINED, (char *)i, ""); } + mask <<= 1; + } deferred_proc = 0; } static char s_unksig[] = "unknown signal"; @@ -189,7 +196,7 @@ static SIGRETTYPE scmable_signal(sig) sigset_t set; sigemptyset(&set); sigaddset(&set, sig); - sigprocmask(SIG_UNBLOCK, &set, 0); + sigprocmask(SIG_UNBLOCK, &set, 0L); #endif SIG_deferred &= ~(1L << i); i += SIGNAL_BASE; @@ -213,12 +220,12 @@ static SIGRETTYPE scmable_signal(sig) #ifdef atarist # undef SIGALRM /* only available via MiNT libs */ #endif -#ifdef GO32 -# undef SIGALRM -#endif #ifdef __HIGHC__ # undef SIGALRM #endif +#ifdef LACK_SETITIMER +# undef SIGPROF +#endif #ifdef SIGALRM static char s_alarm[] = "alarm"; SCM lalarm(i) @@ -231,26 +238,53 @@ SCM lalarm(i) } # ifdef SIGPROF # include -static char s_proftimer[] = "profile-timer"; -SCM scm_proftimer(interval) - SCM interval; +static char s_setitimer[] = "setitimer"; +static SCM setitimer_iv[3]; +/* VALUE and INTERVAL are milliseconds */ +SCM scm_setitimer(which, value, interval) + SCM which, value, interval; { struct itimerval tval, oval; int w; - if (UNBNDP(interval)) - SYSCALL(w = getitimer(ITIMER_PROF, &oval);); +# ifdef ITIMER_REAL + if (which==setitimer_iv[0]) { + w = ITIMER_REAL; + goto doit; + } +# endif +# ifdef ITIMER_VIRTUAL + if (which==setitimer_iv[1]) { + w = ITIMER_VIRTUAL; + goto doit; + } +# endif +# ifdef ITIMER_PROF + if (which==setitimer_iv[2]) { + w = ITIMER_PROF; + goto doit; + } +# endif + return BOOL_F; + doit: + if (BOOL_T==value) + SYSCALL(w = getitimer(w, &oval);); else { + if (BOOL_F==value) value = INUM0; + ASSERT(INUMP(value), value, ARG2, s_setitimer); if (BOOL_F==interval) interval = INUM0; - ASSERT(INUMP(interval), interval, ARG2, s_proftimer); + ASSERT(INUMP(interval), interval, ARG3, s_setitimer); + tval.it_value.tv_sec = INUM(value) / 1000; + tval.it_value.tv_usec = (INUM(value) % 1000)*1000; 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);); + SYSCALL(w = setitimer(w, &tval, &oval);); } if (w) return BOOL_F; - return MAKINUM(oval.it_interval.tv_usec/1000 + - oval.it_interval.tv_sec*1000); + return cons2(MAKINUM(oval.it_value.tv_usec/1000 + + oval.it_value.tv_sec*1000), + MAKINUM(oval.it_interval.tv_usec/1000 + + oval.it_interval.tv_sec*1000), + EOL); } # endif # ifndef AMIGA @@ -290,34 +324,32 @@ SCM l_sleep(i) #endif #ifndef _WIN32 -# ifndef GO32 -# ifndef sun -# ifndef THINK_C +# 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 -# ifndef __MWERKS__ +# 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 @@ -346,9 +378,6 @@ 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; @@ -358,7 +387,7 @@ typedef long STACKITEM; /* 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 ) +void init_scm(iverbose, buf0stdin, init_heap_size) int iverbose; int buf0stdin; long init_heap_size; @@ -370,8 +399,8 @@ void init_scm( iverbose, buf0stdin, init_heap_size ) init_tables(); init_storage(&i, init_heap_size); /* CONT(rootcont)->stkbse gets set here */ } - if (buf0stdin) CAR(def_inp) |= BUF0; - else CAR(def_inp) &= ~BUF0; + if (buf0stdin) SCM_PORTFLAGS(def_inp) |= BUF0; + else SCM_PORTFLAGS(def_inp) &= ~BUF0; if (!dumped) { init_features(); init_subrs(); @@ -379,11 +408,18 @@ void init_scm( iverbose, buf0stdin, init_heap_size ) init_scl(); init_eval(); init_time(); - init_repl( iverbose ); + init_repl(iverbose); init_unif(); } - else { - reset_time(); + else reset_time(); +#ifdef HAVE_DYNL + /* init_dynl() must check dumped to avoid redefining subrs */ + init_dynl(); +#endif + if (!dumped) { +#ifdef INITS + INITS; /* call initialization of extension files */ +#endif } } @@ -419,6 +455,9 @@ void init_signals() # ifdef SIGPROF init_sig1(PROF_SIGNAL, SIGPROF, scmable_signal); # endif +# ifdef SIGVTALRM + init_sig1(VTALRM_SIGNAL, SIGVTALRM, scmable_signal); +# endif #endif #ifdef SIGPIPE oldpipe = signal(SIGPIPE, SIG_IGN); @@ -461,7 +500,7 @@ void ignore_signals() { sigset_t set; sigfillset(&set); - sigprocmask(SIG_UNBLOCK, &set, 0); + sigprocmask(SIG_UNBLOCK, &set, 0L); } #endif } @@ -469,7 +508,7 @@ void ignore_signals() void unignore_signals() { int i = NUM_SIGNALS; - while (i--) + while (i--) if (sigdesc[i].signo) signal(sigdesc[i].signo, sigdesc[i].nsig); #ifdef ultrix @@ -482,7 +521,7 @@ void unignore_signals() void restore_signals() { - int i = NUM_SIGNALS; + int i; #ifdef ultrix siginterrupt(SIGINT, 0); siginterrupt(SIGALRM, 0); @@ -490,75 +529,65 @@ void restore_signals() siginterrupt(SIGPIPE, 0); #endif /* ultrix */ #ifdef SIGALRM +# ifndef SIGPROF alarm(0); /* kill any pending ALRM interrupts */ -# ifdef SIGPROF - scm_proftimer(BOOL_F); /* Turn off interval timer interrupt */ +# else + i = sizeof(setitimer_iv)/sizeof(SCM); + while (i--) + scm_setitimer(setitimer_iv[i], BOOL_F, BOOL_F); # endif #endif + i = NUM_SIGNALS; while (i--) - if (sigdesc[i].signo) + 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) + +void scm_init_from_argv(argc, argv, script_arg, iverbose, buf0stdin) int argc; char **argv; + char *script_arg; 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); - -#ifdef HAVE_DYNL - /* init_dynl() must check dumped to avoid redefining subrs */ - init_dynl(); -#endif - - if (!dumped) { -#ifdef INITS - INITS; /* call initialization of extension files */ -#endif - } - init_signals(); - i = repl_driver(initpath); - restore_signals(); + long 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); + sysintern("*script*", script_arg ? makfrom0str(script_arg) : BOOL_F); +} +void final_scm(freeall) + int freeall; +{ #ifdef TICKS - ticken = 0; + ticken = 0; #endif #ifdef FINALS - FINALS; /* call shutdown of extensions files */ + 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); + /* call finalization of user extensions */ + { + int k = num_finals; + while (k--) (finals[k])(); + } + final_repl(); + if (freeall) free_storage(); /* free all allocated memory */ } #ifdef __CYGWIN32__ @@ -623,162 +652,84 @@ int run_scm(argc, argv, iverbose, buf0stdin, initpath) #ifdef nosve # define DIRSEP "." #endif +#ifdef __amigados__ +# define SYSTNAME "amiga" +# define DIRSEP "/" +#endif +const char dirsep[] = DIRSEP; SCM softtype() { #ifdef nosve - return CAR(intern("nosve", 5)); + return CAR(sysintern("nosve", UNDEFINED)); #else - return CAR(intern(SYSTNAME, sizeof SYSTNAME/sizeof(char) -1)); + return CAR(sysintern(SYSTNAME, UNDEFINED)); #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 DIRSEP -# define DIRSEP "/" -# endif -# ifndef GENERIC_NAME -# define GENERIC_NAME "scm" -# endif - -int main(argc, argv) - int argc; - char **argv; +int init_buf0(inport) + FILE *inport; { - 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); - } - else { - nargv = argv; - nargc = argc; - } -# 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); - } - } -# endif - 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 - /* 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() */ -# ifndef NOSETBUF -# ifndef _DCC -# ifndef ultrix -# ifndef __WATCOMC__ -# ifndef macintosh -# if (__TURBOC__ != 1) -# ifndef _Windows - setbuf(stdin, 0); /* Often setbuf isn't actually required */ -# endif -# endif + if (isatty(fileno(inport))) { +#ifndef NOSETBUF +# ifndef _DCC +# ifndef ultrix +# ifndef __WATCOMC__ +# ifndef macintosh +# if (__TURBOC__ != 1) +# ifndef _Windows + setbuf(inport, 0L); /* Often setbuf isn't actually required */ # endif # endif # endif # endif - } # endif # endif - retval = run_scm(nargc, nargv, - (isatty(fileno(stdin)) && isatty(fileno(stdout))) - ? (nargc <= 1) ? 2 : 1 : 0, - buf0stdin, - implpath ? implpath : ""); - if (implpath) free(implpath); + return !0; /* stdin gets marked BUF0 in init_scm() */ + } +#endif + return 0; +} + +char *execpath = 0; +char s_no_execpath[] = "no execpath"; +#define s_execpath (s_no_execpath+3) +SCM scm_execpath(newpath) + SCM newpath; +{ + SCM retval = execpath ? makfrom0str(execpath) : BOOL_F; + if (UNBNDP(newpath)) + return retval; + if (FALSEP(newpath)) { + if (execpath) free(execpath); + execpath = 0; + return retval; + } + ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_execpath); if (execpath) free(execpath); - execpath = 0; + execpath = (char *)malloc((sizet)(LENGTH(newpath) + 1)); + ASSERT(execpath, newpath, NALLOC, s_execpath); + strncpy(execpath, CHARS(newpath), LENGTH(newpath) + 1); return retval; } -#endif - -char *scm_find_executable() +char *scm_find_execpath(argc, argv, script_arg) + int argc; + char **argv; + char *script_arg; { - char *execpath = 0; + char *exepath = 0; #ifndef macintosh # ifdef unix # ifndef MSDOS - if (script_arg) - execpath = script_find_executable(script_arg); + if (script_arg) exepath = 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); */ + if (!exepath && argv[0]) exepath = dld_find_executable(argv[0]); +/*fprintf(stderr, "scm_find_execpath: argv[0] = %s; script_arg = %s; exepath = %s\n", argv[0], script_arg, exepath); 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; + return exepath; } - #ifndef _Windows char s_system[] = "system"; SCM lsystem(cmd) @@ -859,20 +810,15 @@ static iproc subr1s[] = { #endif #ifdef SIGALRM {s_alarm, lalarm}, -# ifdef SIGPROF - {s_proftimer, scm_proftimer}, -# endif #endif #ifndef AMIGA # ifndef _Windows {s_sleep, l_sleep}, # endif #endif -#ifndef GO32 -# ifndef sun -# ifndef _WIN32 +#ifndef sun +# ifndef _WIN32 {s_raise, l_raise}, -# endif # endif #endif {0, 0}}; @@ -881,13 +827,22 @@ SCM *loc_features; void add_feature(str) char* str; { - *loc_features = cons(CAR(intern(str, strlen(str))), *loc_features); + *loc_features = cons(CAR(sysintern(str, UNDEFINED)), *loc_features); } void init_features() { loc_features = &CDR(sysintern("*features*", EOL)); init_iprocs(subr0s, tc7_subr_0); init_iprocs(subr1s, tc7_subr_1); + make_subr(s_execpath, tc7_subr_1o, scm_execpath); +#ifdef SIGALRM +# ifdef SIGPROF + make_subr(s_setitimer, tc7_subr_3, scm_setitimer); + setitimer_iv[0] = CAR(sysintern("real", UNDEFINED)); + setitimer_iv[1] = CAR(sysintern("virtual", UNDEFINED)); + setitimer_iv[2] = CAR(sysintern("profile", UNDEFINED)); +# endif +#endif #ifdef TICKS loc_tick_signal = &CDR(sysintern("ticks-interrupt", UNDEFINED)); make_subr(s_ticks, tc7_subr_1o, lticks); -- cgit v1.2.3