/* * * t o p l e v e l . c -- The REP loop * * Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI * * Permission to use, copy, modify, distribute,and license this * software and its documentation for any purpose is hereby granted, * provided that existing copyright notices are retained in all * copies and that this notice is included verbatim in any * distributions. No written agreement, license, or royalty fee is * required for any of the authorized uses. * This software is provided ``AS IS'' without express or implied * warranty. * * Author: Erick Gallesio [eg@kaolin.unice.fr] * Creation date: 6-Apr-1994 14:46 * Last file update: 3-Sep-1999 21:01 (eg) * * Modifications made by Steve Pruitt fot Win32 * To maintain compatability with Tcl Library paths and * For Win32 support the following changes were made: * - Defined IMPORT_DLL_GLOBALS for dll support * - Copyright symbol changed to (c) */ /* Import DLL globals from library */ #if defined(WIN32) && defined(USE_DYNLOAD) && defined(MSC_VER) && !defined(CYGWIN32) # define IMPORT_DLL_GLOBALS #endif #include "stk.h" #include "gc.h" #include "module.h" #ifndef WIN32 struct error_handler *STk_err_handler; /* Current error handler pointer */ #else # if (defined(USE_DYNLOAD) && defined(MSC_VER) && !defined(CYGWIN32)) __declspec( dllimport ) struct error_handler *STk_err_handler; # else struct error_handler *STk_err_handler; # endif #endif static struct obj VNIL = {{NULL}, 0, tc_nil}; /* The cell representing NIL */ static void print_banner(void) { if (STk_lookup_variable(PRINT_BANNER, NIL) != Ntruth){ Fprintf(STk_curr_eport, "Welcome to the STk interpreter version %s [%s]\n", STK_VERSION, MACHINE); #ifdef WIN32 /* the copyright symbol does not work on WIN32 system */ Fprintf(STk_curr_eport, "Copyright (c) 1993-1999 Erick Gallesio - "); #else Fprintf(STk_curr_eport, "Copyright © 1993-1999 Erick Gallesio - "); #endif Fprintf(STk_curr_eport, "I3S - CNRS / ESSI \n"); } } static void weird_dirs(char *argv0) { panic("Could not find the directory where STk was installed.\nPerhaps some directories don't exist, or current executable (\"%s\") is in a strange place.\nYou should consider to set the \"STK_LIBRARY\" shell variable.", argv0); } #ifdef USE_TK static void no_display(char *argv0) { panic("DISPLAY variable is not set. Tk cannot be initialized. Please use command line option ``-no-tk'' when executing \"%s\"", argv0); } #endif static void load_init_file(void) { /* Try to load init.stk in "." and, if not present, in $STK_LIBRARY/STk */ char init_file[] = "init.stk"; char file[2*MAX_PATH_LENGTH]; sprintf(file, "./%s", init_file); if (STk_load_file(file, FALSE, STk_selected_module) == Truth) return; sprintf(file, "%s/STk/%s", STk_library_path, init_file); if (STk_load_file(file, FALSE, STk_selected_module) == Ntruth) weird_dirs(STk_Argv0); } static void load_user_init_file(void) { /* Try to load .stkrc in "." and, if not present, in $HOME */ char init_file[] = ".stkrc"; char file[2*MAX_PATH_LENGTH]; char *s; sprintf(file, "./%s", init_file); if (STk_load_file(file, FALSE, STk_selected_module) == Truth) return; if ((s = getenv("HOME")) != NULL) { sprintf(file, "%s/%s", s, init_file); STk_load_file(file, FALSE, STk_selected_module); } } static void init_library_path(char *argv0) { char *s; STk_library_path = ""; if ((s = getenv("STK_LIBRARY"))) { /* Initialize STk_library_path with the content of STK_LIBRARY * shell variable. * Make a copy of environment variable (copy is necessary for * images files) */ STk_library_path = (char *) must_malloc(strlen(s) + 1); strcpy(STk_library_path, s); } else { SCM canonical_argv0 = STk_resolve_link(argv0, 0); if (canonical_argv0 != Ntruth) { /* STk_library must be set to the parent directory of the executable */ char *s, *e; s = CHARS(canonical_argv0); e = s + strlen(s) - 1; while (e > s && !ISDIRSEP(*e)) e -= 1; /* delete exec name */ e -= 1; while (e > s && !ISDIRSEP(*e)) e -= 1; /* delete directory name */ *e = '\0'; STk_library_path = must_malloc(strlen(s) + 1); strcpy(STk_library_path, s); } else weird_dirs(argv0); } } static SCM get_last_defined(char *name) { return STk_last_defined; } static void set_last_defined(char *name, SCM val) { STk_last_defined = val; } /* * Panic procedure. */ static void panic_proc(char *format, ...) { va_list ap; char buf[1024]; char *fmt= "\n**** Fatal error in STk:\n**** %s\n**** ABORT.\n"; va_start(ap, format); vsprintf(buf, format, ap); #ifdef WIN32 MessageBeep(MB_ICONEXCLAMATION); MessageBox(NULL, buf, "Fatal error in STk", MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); #else if (STk_curr_eport == NULL) fprintf(stderr, fmt, buf); /* IO are not yet fully initialized */ else Fprintf(STk_curr_eport, fmt, buf); #endif exit(1); } static void init_interpreter(void) { /* Remember if we are running the stk or snow interpreter */ #ifdef USE_TK STk_snow_is_running = FALSE; #else STk_snow_is_running = TRUE; #endif /* Global variables to initialize */ STk_tkbuffer = (char *) must_malloc(TKBUFFERN+1); STk_is_safe = 0; NIL = &VNIL; /* Initialize GC */ STk_init_gc(); /* Initialize symbol & keyword tables */ STk_initialize_symbol_table(); STk_initialize_keyword_table(); /* * Define some scheme objects used by the interpreter * and protect them against GC */ NEWCELL(UNDEFINED, tc_undefined); STk_gc_protect(&UNDEFINED); NEWCELL(UNBOUND, tc_unbound); STk_gc_protect(&UNBOUND); NEWCELL(Truth, tc_boolean); STk_gc_protect(&Truth); NEWCELL(Ntruth, tc_boolean); STk_gc_protect(&Ntruth); Sym_lambda = Intern("lambda"); STk_gc_protect(&Sym_lambda); Sym_quote = Intern("quote"); STk_gc_protect(&Sym_quote); Sym_imply = Intern("=>"); STk_gc_protect(&Sym_imply); Sym_dot = Intern("."); STk_gc_protect(&Sym_dot); Sym_debug = Intern(DEBUG_MODE); STk_gc_protect(&Sym_debug); Sym_else = Intern("else"); STk_gc_protect(&Sym_else); Sym_quasiquote = Intern("quasiquote"); STk_gc_protect(&Sym_quasiquote); Sym_unquote = Intern("unquote"); STk_gc_protect(&Sym_unquote); Sym_unq_splicing = Intern("unquote-splicing"); STk_gc_protect(&Sym_unq_splicing); Sym_break = Intern("break"); STk_gc_protect(&Sym_break); STk_globenv = STk_makeenv(NIL, 1); STk_gc_protect(&STk_globenv); /* GC_VERBOSE and REPORT_ERROR must ABSOLUTLY initialized before any GC occurs * Otherwise, they will be allocated during a GC and this lead to an infinite * loop */ STk_define_variable(GC_VERBOSE, Ntruth, NIL); STk_define_variable(REPORT_ERROR, NIL, NIL); /* Initialize standard ports */ STk_init_standard_ports(); /* Initialize module system */ STk_init_modules(); /* Initialize the path of the library */ init_library_path(STk_Argv0); /* Initialize *eval-hook* */ STk_init_eval_hook(); /* Initialize Scheme primitives */ STk_init_primitives(); /* Initialize signal table */ STk_init_signal(); /* Define some global variables */ STk_define_variable(LOAD_SUFFIXES, NIL, NIL); STk_define_variable(LOAD_PATH, NIL, NIL); STk_define_variable(LOAD_VERBOSE, Ntruth, NIL); STk_define_variable(STK_LIBRARY, STk_makestring(STk_library_path), NIL); /* Initialize C variables */ STk_last_defined = Ntruth; STk_define_C_variable(LAST_DEFINED, get_last_defined, set_last_defined); STk_gc_protect(&STk_last_defined); } static void finish_initialisation(void) { /* * Initialize user extensions */ STk_user_init(); /* * See if we have the '-file' option */ if (STk_arg_file) { STk_set_signal_handler(STk_makeinteger(SIGINT), Truth); STk_interactivep = 0; if (STk_load_file(STk_arg_file, FALSE, STk_selected_module) == Ntruth) panic("Cannot open file \"%s\".", STk_arg_file); #ifdef USE_TK if (Tk_initialized){ STk_internal_eval_string("(tk-set-error-handler!)", 0, NIL); /* Do it late */ Tk_MainLoop(); } #endif exit(0); } else STk_interactivep = STk_arg_interactive || #ifdef USE_TK STk_arg_console || #endif isatty(fileno(PORT_FILE(STk_stdin))); /* * See if we are interactive: * 1/ Create a console if needed; * 2/ Unbufferize stdout and stderr so that the interpreter can be * used with Emacs and * 3/ print the STk banner * 4/ set the input handler if we are on Unix */ if (STk_interactivep) { static char *out, *err; #ifdef USE_TK if (STk_arg_console) STk_init_console(); #endif out = STk_line_bufferize_io(STk_stdout); err = STk_line_bufferize_io(STk_stderr); print_banner(); #if (defined(USE_TK) && !defined(WIN32)) if (!STk_arg_console) /* Set up a handler for characters coming from stdin */ Tcl_CreateFileHandler(fileno(PORT_FILE(STk_stdin)), TCL_READABLE, (Tk_FileProc *) STk_StdinProc, (ClientData) NULL); #endif } Flush(STk_curr_oport); /* * Manage -load option */ if (STk_arg_load) { STk_load_file(STk_arg_load, TRUE, STk_selected_module); #ifdef USE_TK if (Tk_initialized) Tcl_GlobalEval(STk_main_interp, "(update)"); #endif } } static void repl_loop(void) { /* The print/eval/read loop */ for( ; ; ) { SCM x; SCM env = MOD_ENV(STk_selected_module); if (STk_interactivep) { #ifdef USE_TK if (STk_arg_console) STk_console_prompt(env); else #endif if (STk_internal_eval_string("(catch (repl-display-prompt (current-module)))", 0, env) == Truth) Fprintf(STk_curr_eport, "STk> "); Flush(STk_curr_oport); Flush(STk_curr_eport); /* This is for Ilisp users */ } if (EQ(x=STk_readf(STk_stdin, FALSE), STk_eof_object)) return; x = STk_eval(x, env); if (STk_dumped_core) { /* * When restoring an image we arrive here x contains the result of applying * the saved continuation. */ STk_dumped_core = 0; longjmp(STk_err_handler->j, JMP_RESTORE); } else { if (STk_interactivep) { STk_define_variable("*repl-result*", x, NIL); if (STk_internal_eval_string("(catch (repl-display-result *repl-result*))", 0, env) == Truth) { STk_print(x, STk_curr_oport, WRT_MODE); Putc('\n', STk_curr_oport); } } } } } static void repl_driver(int argc, char **argv) { static int k; static char **new_argv; struct error_handler err_handler; /* Inititialize the error handler. */ STk_err_handler = &err_handler; err_handler.prev = NULL; err_handler.context = ERR_FATAL; err_handler.dynamic_handler = &VNIL; /* since NIL is not yet initialized */ /* Initialize IO and set the panic procedure */ STk_init_io(); Tcl_SetPanicProc(panic_proc); new_argv = STk_process_argc_argv(argc, argv); if (STk_arg_image) { STk_save_unix_args_and_environment(argc, argv); STk_restore_image(STk_arg_image); } else { /* Normal initialisation */ STk_reset_eval_stack(); } /* We come back here on errors, image restauration, ... */ k = setjmp(err_handler.j); err_handler.context = ERR_OK; switch (k) { case 0: init_interpreter(); STk_initialize_scheme_args(new_argv); load_init_file(); /* And now set the default module to the global one */ STk_initialize_stk_module(); #ifdef USE_TK # ifdef WIN32 if (!STk_arg_no_tk) Tk_main(STk_arg_sync, STk_arg_name, STk_arg_file, "localhost:0", STk_arg_geometry); # else if (!STk_arg_Xdisplay) STk_arg_Xdisplay = getenv("DISPLAY"); if (!STk_arg_no_tk) { if (!STk_arg_Xdisplay) no_display(STk_Argv0); Tk_main(STk_arg_sync, STk_arg_name, STk_arg_file, STk_arg_Xdisplay, STk_arg_geometry); } # endif #endif load_user_init_file(); finish_initialisation(); break; case JMP_RESTORE: STk_restore_unix_args_and_environment(&argc, &argv); /* Process another time args since we have lost them ! */ new_argv = STk_process_argc_argv(argc, argv); STk_initialize_scheme_args(new_argv); #ifdef USE_TK if (!STk_arg_no_tk && (STk_arg_Xdisplay||getenv("DISPLAY"))) Tk_main(STk_arg_sync, STk_arg_name, STk_arg_file, STk_arg_Xdisplay, STk_arg_geometry); #endif finish_initialisation(); break; case JMP_THROW: case JMP_ERROR: break; case JMP_INTERRUPT: STk_control_C = 0; STk_err_handler = &err_handler; STk_reset_eval_stack(); break; } repl_loop(); if (STk_interactivep) Fprintf(STk_curr_eport, "Bye.\n"); STk_quit_interpreter(UNBOUND); } /****************************************************************************** * * Toplevel * ******************************************************************************/ void STk_toplevel(int argc, char **argv) { SCM stack_start; /* Unused variable. Its the first stack allocated variable */ STk_stack_start_ptr = &stack_start; repl_driver(argc, argv); }