/* main.c -- Entry point for Jade Copyright (C) 1993, 1994 John Harper $Id: main.c,v 1.70 2001/08/24 03:05:41 jsh Exp $ This file is part of Jade. Jade 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. Jade 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 Jade; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE #include "repint.h" #include #include void *rep_common_db; int rep_recurse_depth = -1; rep_bool (*rep_on_idle_fun)(int since_last); DEFSYM(idle_hook, "idle-hook"); /* ::doc:idle-hook:: This hook gets evaluated every second while the editor is idle. Don't depend on how regularly this gets called, any events from the window-system will delay it. Also, auto-saving files and garbage-collection take precedence when there's idle time available. Use this hook sparingly, or for short periods only! ::end:: ::doc:program-name:: The name of the program running the rep interpreter. ::end:: ::doc:error-mode:: When nil, errors are handled at the current event loop, other possible values include `exit' and `top-level'. ::end:: ::doc:interrupt-mode:: When nil, interrupts are handled at the current event loop, other possible values include `exit' and `top-level'. ::end:: */ /* Called when we get a termination signal. */ void (*rep_on_termination_fun)(void); /* The event-loop function, may be entered recursively. */ repv (*rep_event_loop_fun)(void) = rep_event_loop; /* rep_init () will set this to an early stack pointer */ char *rep_stack_bottom; DEFSYM(exit, "exit"); DEFSYM(quit, "quit"); DEFSYM(top_level, "top-level"); DEFSYM(command_line_args, "command-line-args"); DEFSYM(batch_mode, "batch-mode"); DEFSYM(interpreted_mode, "interpreted-mode"); DEFSYM(program_name, "program-name"); DEFSYM(error_mode, "error-mode"); DEFSYM(interrupt_mode, "interrupt-mode"); DEFSYM(before_exit_hook, "before-exit-hook"); static void rep_main_init(void); DEFSTRING(noarg, "No argument for option"); /* Look for the command line option called OPTION. If ARGP is non-null, the option requires an argument, it will be stored in *ARGP. If the option isn't given return false, else return true. */ rep_bool rep_get_option (char *option, repv *argp) { int optlen = strlen(option); repv tem = Fsymbol_value (Qcommand_line_args, Qt); while (!rep_INTERRUPTP && rep_CONSP(tem) && rep_STRINGP(rep_CAR(tem))) { if (strncmp (option, rep_STR(rep_CAR(tem)), optlen) == 0) { repv opt = rep_CAR(tem), cdr = rep_CDR(tem); if (rep_STR(opt)[optlen] == '=' || rep_STR(opt)[optlen] == 0) { Fset (Qcommand_line_args, Fdelq (opt, Fsymbol_value (Qcommand_line_args, Qt))); if (argp != 0) { if (rep_STR(opt)[optlen] == '=') { *argp = rep_string_dup (rep_STR(opt) + optlen + 1); return rep_TRUE; } else if (rep_CONSP(cdr) && rep_STRINGP(rep_CAR(cdr))) { *argp = rep_CAR(cdr); Fset (Qcommand_line_args, Fdelq (*argp, Fsymbol_value(Qcommand_line_args, Qt))); return rep_TRUE; } else { Fsignal (Qerror, rep_list_2(rep_VAL(&noarg), rep_string_dup(option))); return rep_FALSE; } } else return rep_TRUE; } } tem = rep_CDR(tem); rep_TEST_INT; } return rep_FALSE; } static int get_main_options(char *prog_name, int *argc_p, char ***argv_p) { int argc = *argc_p; char **argv = *argv_p; repv head, *last; /* any command line args are made into a list of strings in symbol command-line-args. */ head = Qnil; last = &head; while(argc > 0) { *last = Fcons(rep_string_dup(*argv), Qnil); last = &rep_CDR(*last); argc--; argv++; } Fset (Qcommand_line_args, head); *argc_p = argc; *argv_p = argv; if (rep_get_option("--batch", 0)) Fset (Qbatch_mode, Qt); if (rep_get_option("--interp", 0)) { Fset (Qinterpreted_mode, Qt); /* XXX somewhat non-related, but.. */ rep_record_origins = rep_TRUE; } return rep_TRUE; } static void check_configuration (int *stack_low) { int stack_high; int stack_dir = (&stack_high < stack_low) ? -1 : +1; if (sizeof (rep_PTR_SIZED_INT) < sizeof(void *)) { fprintf (stderr, " ** error: --with-value-type is incorrect; it should be `%s'\n", (sizeof (int) >= sizeof (void *)) ? "int" : (sizeof (long) >= sizeof (void *)) ? "long" : (sizeof (rep_long_long) >= sizeof (void *)) ? "long long" : ""); exit (10); } if (sizeof (rep_PTR_SIZED_INT) != rep_PTR_SIZED_INT_SIZEOF) { fprintf (stderr, " ** error: --with-value-sizeof is incorrect; it should be %d\n", sizeof (rep_PTR_SIZED_INT)); exit (10); } if (stack_dir != STACK_DIRECTION) { fprintf (stderr, " ** error: --with-stack-direction is incorrect; it should be %d\n", stack_dir); exit (10); } } /* Note that `argc' _must_ (I mean _must_!) be a pointer to the real argc on the stack frame of the outermost procedure */ void rep_init(char *prog_name, int *argc, char ***argv, void (*sys_symbols)(void), void (*obsolete_sys_usage)(void)) { #ifdef ENABLE_BROKEN_DUMPING char *dump_file = getenv ("REPDUMPFILE"); #else char *dump_file = 0; #endif rep_init_from_dump (prog_name, argc, argv, sys_symbols, obsolete_sys_usage, dump_file); } void rep_init_from_dump(char *prog_name, int *argc, char ***argv, void (*sys_symbols)(void), void (*obsolete_sys_usage)(void), char *dump_file) { int dummy; check_configuration (&dummy); if(!sys_memory_init()) exit(10); rep_common_db = rep_db_alloc("common", 4096); rep_pre_values_init(); rep_pre_sys_os_init(); if(rep_pre_symbols_init()) { #ifdef ENABLE_BROKEN_DUMPING char *tem = getenv ("REPUNDUMPED"); if (dump_file && (!tem || atoi(tem) == 0)) rep_dumped_init (dump_file); #endif rep_symbols_init(); rep_structures_init (); rep_numbers_init (); rep_lisp_init(); rep_values_init(); rep_origin_init (); /* must be after values */ rep_macros_init (); rep_lispcmds_init(); rep_lispmach_init(); rep_find_init(); rep_main_init(); rep_misc_init(); rep_streams_init(); rep_files_init(); rep_datums_init(); rep_fluids_init(); rep_weak_refs_init (); rep_sys_os_init(); /* XXX Assumes that argc is on the stack. I can't think of XXX any other way to reliably find the real base of the XXX stack.. */ rep_stack_bottom = (char *) argc; rep_continuations_init (); if (sys_symbols != 0) (*sys_symbols)(); Fset (Qprogram_name, rep_string_dup (prog_name)); if(get_main_options(prog_name, argc, argv)) return; } exit (10); } /* Should be called sometime after calling rep_init*. It will load the standard init scripts, plus FILE if non-nil. Returns the result of the last form evaluated. */ repv rep_load_environment (repv file) { /* Modules that have Lisp code stored in the filing system. */ static const char *init[] = { "rep.lang.interpreter", "rep.structures", "rep.module-system", "rep.lang.math", "rep.data", "rep.regexp", "rep.system", "rep.io.streams", "rep.io.files", "rep.io.file-handlers", "rep", 0 }; const char **ptr; repv res = Qnil; rep_GC_root gc_file; rep_PUSHGC (gc_file, file); /* 1. Do the rep bootstrap */ if (rep_dumped_non_constants != rep_NULL) res = Feval (rep_dumped_non_constants); for (ptr = init; res != rep_NULL && *ptr != 0; ptr++) { res = rep_bootstrap_structure (*ptr); } /* 2. Do the caller-local bootstrap */ if (res != rep_NULL && rep_STRINGP(file)) res = Fload (file, Qnil, Qnil, Qnil, Qnil); rep_POPGC; return res; } void rep_kill(void) { rep_sys_os_kill(); rep_find_kill(); rep_files_kill(); #ifdef HAVE_DYNAMIC_LOADING rep_kill_dl_libraries(); #endif rep_lispmach_kill(); rep_db_kill(); rep_tuples_kill(); rep_values_kill(); sys_memory_kill(); } /* This function gets called when we have idle time available. The single argument is the number of seconds since we weren't idle. The first idle period after a non-idle period should pass zero. Returns rep_TRUE if the display should be refreshed. */ rep_bool rep_on_idle(long since_last_event) { static rep_bool called_hook; static int depth; rep_bool res = rep_FALSE; depth++; /* A timeout; do one of: * Remove messages in minibuffers * Print the current key-prefix * Auto-save a buffer * GC if enough data allocated * Run the `idle-hook' (only once per idle-period) */ if(since_last_event == 0) called_hook = rep_FALSE; if(rep_on_idle_fun != 0 && (*rep_on_idle_fun)(since_last_event)) res = rep_TRUE; else if(rep_data_after_gc > rep_idle_gc_threshold) /* nothing was saved so try a GC */ Fgarbage_collect (Qnil); else if(!called_hook && depth == 1) { repv hook = Fsymbol_value(Qidle_hook, Qt); if(!rep_VOIDP(hook) && !rep_NILP(hook)) { Fcall_hook(hook, Qnil, Qnil); res = rep_TRUE; } called_hook = rep_TRUE; } depth--; return res; } /* The input loop should call this function when rep_throw_value == rep_NULL. It returns rep_TRUE when the input loop should exit, returning whatever is stored in *RESULT-P. */ rep_bool rep_handle_input_exception(repv *result_p) { repv tv = rep_throw_value; repv car = rep_CAR(tv); rep_throw_value = rep_NULL; *result_p = rep_NULL; if(car == Qexit) { *result_p = rep_CDR(tv); if(rep_recurse_depth > 0) return rep_TRUE; } else if((car == Qtop_level) && (rep_recurse_depth == 0)) *result_p = rep_CDR(tv); else if(car == Qquit) { *result_p = rep_CDR(tv); return rep_TRUE; } else if(car == Quser_interrupt) { repv tem = Fsymbol_value (Qinterrupt_mode, Qt); if (tem == Qexit && rep_recurse_depth == 0) goto terminate; else if (rep_recurse_depth == 0 || tem != Qtop_level) rep_handle_error(car, Qnil); else goto unhandled; } else if(car == Qerror) { repv tem = Fsymbol_value (Qerror_mode, Qt); if (tem == Qexit && rep_recurse_depth == 0) { rep_handle_error(rep_CAR(rep_CDR(tv)), rep_CDR(rep_CDR(tv))); goto terminate; } else if (rep_recurse_depth == 0 || tem != Qtop_level) rep_handle_error(rep_CAR(rep_CDR(tv)), rep_CDR(rep_CDR(tv))); else goto unhandled; } else if(car == Qterm_interrupt) { terminate: if(rep_recurse_depth == 0 && rep_on_termination_fun != 0) (*rep_on_termination_fun)(); *result_p = Qnil; return rep_TRUE; } #if 0 else if(rep_recurse_depth == 0) rep_handle_error(Qno_catcher, rep_LIST_1(car)); #endif else { unhandled: rep_throw_value = tv; return rep_TRUE; } return rep_FALSE; } /* should be called before exiting (for any reason). returns the value that should be returned by the process */ int rep_top_level_exit (void) { rep_GC_root gc_throw; repv throw = rep_throw_value; rep_throw_value = rep_NULL; if(throw && rep_CAR(throw) == Qerror) { /* If quitting due to an error, print the error cell if at all possible. */ repv stream = Fstderr_file(); if(stream && rep_FILEP(stream)) { fputs("error--> ", stderr); Fprin1(rep_CDR(throw), stream); fputc('\n', stderr); } else fputs("error in initialisation\n", stderr); return 10; } rep_PUSHGC(gc_throw, throw); Fcall_hook (Qbefore_exit_hook, Qnil, Qnil); rep_throw_value = rep_NULL; rep_POPGC; if (throw && rep_CAR (throw) == Qquit && rep_INTP (rep_CDR(throw))) return (rep_INT (rep_CDR(throw))); return 0; } DEFUN_INT("recursive-edit", Frecursive_edit, Srecursive_edit, (void), rep_Subr0, "") /* ::doc:rep.system#recursive-edit:: recursive-edit Enter a new recursive-edit. ::end:: */ { repv ret; rep_recurse_depth++; ret = (*rep_event_loop_fun)(); rep_recurse_depth--; #ifdef C_ALLOCA /* Using the C implementation of alloca. So garbage collect anything below the current stack depth. */ alloca(0); #endif return ret; } /* Called from the main function of input-driven programs. Avoids the program exiting due to an unhandled exception */ repv rep_top_level_recursive_edit (void) { repv ret; again: ret = Frecursive_edit (); if (rep_recurse_depth < 0 && rep_throw_value && rep_CONSP (rep_throw_value)) { repv type = rep_CAR (rep_throw_value); if (type != Qquit && type != Qerror && type != Qterm_interrupt && type != Quser_interrupt) { rep_throw_value = rep_NULL; rep_handle_error (Qno_catcher, rep_LIST_1 (type)); goto again; } } return ret; } DEFUN("recursion-depth", Frecursion_depth, Srecursion_depth, (void), rep_Subr0) /* ::doc:rep.system#recursion-depth:: recursion-depth Returns the number of recursive-edit's deep we are, zero signifies the original level. ::end:: */ { return rep_MAKE_INT(rep_recurse_depth); } void rep_deprecated (rep_bool *seen, const char *desc) { if (!*seen) { fprintf (stderr, "rep: using deprecated feature - %s\n", desc); *seen = rep_TRUE; } } static void rep_main_init(void) { repv tem = rep_push_structure ("rep.system"); rep_ADD_SUBR_INT(Srecursive_edit); rep_ADD_SUBR(Srecursion_depth); rep_pop_structure (tem); rep_INTERN(quit); rep_INTERN(exit); rep_INTERN(top_level); rep_INTERN_SPECIAL(command_line_args); rep_INTERN_SPECIAL(idle_hook); rep_INTERN_SPECIAL(batch_mode); Fset (Qbatch_mode, Qnil); rep_INTERN_SPECIAL(interpreted_mode); Fset (Qinterpreted_mode, Qnil); rep_INTERN_SPECIAL(program_name); rep_INTERN_SPECIAL(error_mode); Fset (Qerror_mode, Qnil); rep_INTERN_SPECIAL(interrupt_mode); Fset (Qinterrupt_mode, Qnil); rep_INTERN_SPECIAL(before_exit_hook); }