123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519 |
- /* Copyright 1995-2004,2006,2009-2014,2016-2021,2023
- Free Software Foundation, Inc.
- This file is part of Guile.
- Guile is free software: you can redistribute it and/or modify it
- under the terms of the GNU Lesser General Public License as published
- by the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
- Guile 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 Lesser General Public
- License for more details.
- You should have received a copy of the GNU Lesser General Public
- License along with Guile. If not, see
- <https://www.gnu.org/licenses/>. */
- #ifdef HAVE_CONFIG_H
- # include <config.h>
- #endif
- #include <fcntl.h>
- #include <stdio.h>
- #include <stdlib.h>
- #include <string.h>
- #include <sys/stat.h>
- #include <unistd.h>
- #include "scm.h"
- #if SCM_ENABLE_MINI_GMP
- #include "mini-gmp.h"
- #else
- #include <gmp.h>
- #endif
- /* Everybody has an init function. */
- #include "alist.h"
- #include "array-map.h"
- #include "arrays.h"
- #include "async.h"
- #include "atomic.h"
- #include "backtrace.h"
- #include "bitvectors.h"
- #include "boolean.h"
- #include "bytevectors.h"
- #include "chars.h"
- #include "continuations.h"
- #include "control.h"
- #include "custom-ports.h"
- #include "debug.h"
- #ifdef GUILE_DEBUG_MALLOC
- #include "debug-malloc.h"
- #endif
- #include "deprecated.h"
- #include "deprecation.h"
- #include "dynl.h"
- #include "dynwind.h"
- #include "eq.h"
- #include "error.h"
- #include "eval.h"
- #include "evalext.h"
- #include "exceptions.h"
- #include "expand.h"
- #include "extensions.h"
- #include "fdes-finalizers.h"
- #include "feature.h"
- #include "filesys.h"
- #include "finalizers.h"
- #include "fluids.h"
- #include "foreign-object.h"
- #include "foreign.h"
- #include "fports.h"
- #include "frames.h"
- #include "gc.h"
- #include "generalized-vectors.h"
- #include "gettext.h"
- #include "goops.h"
- #include "gsubr.h"
- #include "guardians.h"
- #include "hash.h"
- #include "hashtab.h"
- #include "hooks.h"
- #include "i18n.h"
- #include "instructions.h"
- #include "intrinsics.h"
- #include "ioext.h"
- #include "jit.h"
- #include "keywords.h"
- #include "list.h"
- #include "load.h"
- #include "loader.h"
- #include "macros.h"
- #include "mallocs.h"
- #include "memoize.h"
- #include "modules.h"
- #include "net_db.h"
- #include "numbers.h"
- #include "objprop.h"
- #include "options.h"
- #include "pairs.h"
- #include "poll.h"
- #include "ports.h"
- #include "posix.h"
- #include "print.h"
- #include "private-options.h"
- #include "procprop.h"
- #include "procs.h"
- #include "programs.h"
- #include "promises.h"
- #ifdef ENABLE_REGEX
- #include "regex-posix.h"
- #endif
- #include "r6rs-ports.h"
- #include "random.h"
- #include "rdelim.h"
- #include "read.h"
- #include "rw.h"
- #include "scmsigs.h"
- #include "script.h"
- #include "simpos.h"
- #include "smob.h"
- #include "socket.h"
- #include "sort.h"
- #include "srcprop.h"
- #include "srfi-1.h"
- #include "srfi-13.h"
- #include "srfi-14.h"
- #include "srfi-4.h"
- #include "srfi-60.h"
- #include "stackchk.h"
- #include "stacks.h"
- #include "stime.h"
- #include "strings.h"
- #include "strorder.h"
- #include "strports.h"
- #include "struct.h"
- #include "symbols.h"
- #include "syntax.h"
- #include "throw.h"
- #include "unicode.h"
- #include "uniform.h"
- #include "values.h"
- #include "variable.h"
- #include "vectors.h"
- #include "version.h"
- #include "vm.h"
- #include "weak-set.h"
- #include "weak-table.h"
- #include "weak-vector.h"
- #include "init.h"
- /* initializing standard and current I/O ports */
- /* Convert a file descriptor to a port, using scm_fdes_to_port.
- - set the revealed count for FILE's file descriptor to 1, so
- that fdes won't be closed when the port object is GC'd. */
- static SCM
- scm_standard_stream_to_port (int fdes, char *mode)
- {
- long mode_bits = scm_mode_bits (mode);
- if (!scm_i_fdes_is_valid (fdes, mode_bits))
- return scm_void_port (mode);
- SCM port = scm_i_fdes_to_port (fdes, mode_bits, SCM_BOOL_F, 0);
- scm_set_port_revealed_x (port, SCM_INUM1);
- return port;
- }
- /* Create standard ports from stdin, stdout, and stderr. */
- static void
- scm_init_standard_ports ()
- {
- /* From the SCSH manual:
- It can be useful to turn I/O buffering off in some cases, for
- example when an I/O stream is to be shared by multiple
- subprocesses. For this reason, scsh allocates an unbuffered port
- for file descriptor 0 at start-up time.
- Because shells frequently share stdin with subprocesses, if the
- shell does buffered reads, it might ``steal'' input intended for
- a subprocess. For this reason, all shells, including sh, csh,
- and scsh, read stdin unbuffered. Applications that can tolerate
- buffered input on stdin can reset \ex{(current-input-port)} to
- block buffering for higher performance. */
- scm_set_current_input_port
- (scm_standard_stream_to_port (0, isatty (0) ? "r0" : "r"));
- scm_set_current_output_port
- (scm_standard_stream_to_port (1, isatty (1) ? "w0" : "w"));
- scm_set_current_error_port
- (scm_standard_stream_to_port (2, isatty (2) ? "w0" : "w"));
- scm_set_current_warning_port (scm_current_error_port ());
- }
- /* Loading the startup Scheme files. */
- /* The boot code "ice-9/boot-9" is only loaded by scm_boot_guile when
- this is false. The unexec code uses this, to keep ice_9 from being
- loaded into dumped guile executables. */
- int scm_ice_9_already_loaded = 0;
- void
- scm_load_startup_files ()
- {
- /* We want a path only containing directories from GUILE_LOAD_PATH,
- SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init
- file, so we do this before loading Ice-9. */
- SCM init_path =
- scm_sys_search_load_path (scm_from_utf8_string ("init.scm"));
- /* Load Ice-9. */
- if (!scm_ice_9_already_loaded)
- {
- scm_c_primitive_load_path ("ice-9/boot-9");
- /* Load the init.scm file. */
- if (scm_is_true (init_path))
- scm_primitive_load (init_path);
- }
- }
- /* The main init code. */
- /* All the data needed to invoke the main function. */
- struct main_func_closure
- {
- /* the function to call */
- void (*main_func)(void *closure, int argc, char **argv);
- void *closure; /* dummy data to pass it */
- int argc;
- char **argv; /* the argument list it should receive */
- };
- static void *invoke_main_func(void *body_data);
- /* Fire up the Guile Scheme interpreter.
- Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV. MAIN_FUNC
- should do all the work of the program (initializing other packages,
- reading user input, etc.) before returning. When MAIN_FUNC
- returns, call exit (EXIT_FAILURE); this function never returns.
- If you want some other exit value, MAIN_FUNC may call exit itself.
- scm_boot_guile arranges for program-arguments to return the strings
- given by ARGC and ARGV. If MAIN_FUNC modifies ARGC/ARGV, should
- call scm_set_program_arguments with the final list, so Scheme code
- will know which arguments have been processed.
- scm_boot_guile establishes a catch-all catch handler which prints
- an error message and exits the process. This means that Guile
- exits in a coherent way when system errors occur and the user isn't
- prepared to handle it. If the user doesn't like this behavior,
- they can establish their own universal catcher to shadow this one.
- Why must the caller do all the real work from MAIN_FUNC? The
- garbage collector assumes that all local variables of type SCM will
- be above scm_boot_guile's stack frame on the stack. If you try to
- manipulate SCM values after this function returns, it's the luck of
- the draw whether the GC will be able to find the objects you
- allocate. So, scm_boot_guile function exits, rather than
- returning, to discourage people from making that mistake. */
- void
- scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
- {
- void *res;
- struct main_func_closure c;
- /* On Windows, convert backslashes in argv[0] to forward
- slashes. */
- if (argc > 0)
- scm_i_mirror_backslashes (argv[0]);
- c.main_func = main_func;
- c.closure = closure;
- c.argc = argc;
- c.argv = argv;
- res = scm_with_guile (invoke_main_func, &c);
- /* If the caller doesn't want this, they should exit from main_func
- themselves.
- */
- if (res == NULL)
- exit (EXIT_FAILURE);
- else
- exit (EXIT_SUCCESS);
- }
- static void *
- invoke_main_func (void *body_data)
- {
- struct main_func_closure *closure = (struct main_func_closure *) body_data;
- scm_i_set_boot_program_arguments (closure->argc, closure->argv);
- (*closure->main_func) (closure->closure, closure->argc, closure->argv);
- scm_restore_signals ();
- /* This tick gives any pending
- * asyncs a chance to run. This must be done after
- * the call to scm_restore_signals.
- */
- scm_async_tick ();
- /* Indicate success by returning non-NULL.
- */
- return (void *)1;
- }
- scm_i_pthread_mutex_t scm_i_init_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
- int scm_initialized_p = 0;
- static void *
- really_cleanup_for_exit (void *unused)
- {
- scm_flush_all_ports ();
- return NULL;
- }
- static void
- cleanup_for_exit ()
- {
- if (scm_i_pthread_mutex_trylock (&scm_i_init_mutex) == 0)
- scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
- else
- {
- fprintf (stderr, "Cannot exit gracefully when init is in progress; aborting.\n");
- abort ();
- }
- /* This function might be called in non-guile mode, so we need to
- enter it temporarily.
- */
- scm_with_guile (really_cleanup_for_exit, NULL);
- }
- void
- scm_i_init_guile (void *base)
- {
- if (scm_initialized_p)
- return;
- scm_storage_prehistory ();
- scm_threads_prehistory (base); /* requires storage_prehistory */
- scm_weak_table_prehistory (); /* requires storage_prehistory */
- #ifdef GUILE_DEBUG_MALLOC
- scm_debug_malloc_prehistory ();
- #endif
- scm_symbols_prehistory (); /* requires weak_table_prehistory */
- scm_modules_prehistory ();
- scm_init_array_handle ();
- scm_bootstrap_bytevectors (); /* Requires array-handle */
- scm_bootstrap_instructions ();
- scm_bootstrap_intrinsics ();
- scm_bootstrap_loader ();
- scm_bootstrap_programs ();
- scm_bootstrap_vm ();
- scm_register_atomic ();
- scm_register_custom_ports ();
- scm_register_fdes_finalizers ();
- scm_register_foreign ();
- scm_register_foreign_object ();
- scm_register_srfi_1 ();
- scm_register_srfi_60 ();
- scm_register_poll ();
- scm_init_strings (); /* Requires array-handle */
- scm_init_struct (); /* Requires strings */
- scm_smob_prehistory ();
- scm_init_variable ();
- scm_init_continuations (); /* requires smob_prehistory */
- scm_init_threads (); /* requires smob_prehistory */
- scm_init_gsubr ();
- scm_init_procprop ();
- scm_init_alist ();
- scm_init_async (); /* requires smob_prehistory */
- scm_init_boolean ();
- scm_init_chars ();
- #ifdef GUILE_DEBUG_MALLOC
- scm_init_debug_malloc ();
- #endif
- scm_init_dynwind (); /* requires smob_prehistory */
- scm_init_eq ();
- scm_init_error ();
- scm_init_finalizers ();
- scm_init_fluids ();
- scm_init_control (); /* requires fluids */
- scm_init_feature ();
- scm_init_backtrace ();
- scm_init_ports ();
- scm_register_r6rs_ports (); /* requires ports */
- scm_init_fports ();
- scm_init_strports ();
- scm_init_hash ();
- scm_init_hashtab ();
- scm_init_deprecation ();
- scm_init_objprop ();
- scm_init_promises (); /* requires smob_prehistory */
- scm_init_hooks (); /* Requires smob_prehistory */
- scm_init_stime ();
- scm_init_gc (); /* Requires hooks and `get_internal_run_time' */
- scm_init_gc_protect_object (); /* requires threads_prehistory */
- scm_init_gettext ();
- scm_init_ioext ();
- scm_init_keywords (); /* Requires smob_prehistory */
- scm_init_fports_keywords ();
- scm_init_list ();
- scm_init_random (); /* Requires smob_prehistory */
- scm_init_macros (); /* Requires smob_prehistory and random */
- scm_init_mallocs (); /* Requires smob_prehistory */
- scm_init_modules (); /* Requires smob_prehistory */
- scm_init_numbers ();
- scm_init_options ();
- scm_init_pairs ();
- scm_init_filesys (); /* Requires smob_prehistory */
- #ifdef HAVE_POSIX
- scm_init_posix ();
- #endif
- #ifdef ENABLE_REGEX
- scm_init_regex_posix (); /* Requires smob_prehistory */
- #endif
- scm_init_procs ();
- scm_init_scmsigs ();
- #ifdef HAVE_NETWORKING
- scm_init_net_db ();
- scm_init_socket ();
- #endif
- scm_init_sort ();
- scm_init_srcprop (); /* requires smob_prehistory */
- scm_init_stackchk ();
- scm_init_generalized_vectors ();
- scm_init_vectors (); /* Requires array-handle, */
- scm_init_uniform ();
- scm_init_bitvectors (); /* Requires smob_prehistory, array-handle */
- scm_bootstrap_srfi_4 (); /* Requires smob_prehistory, array-handle */
- scm_init_arrays (); /* Requires smob_prehistory, array-handle */
- scm_init_array_map ();
- scm_init_frames (); /* Requires smob_prehistory */
- scm_init_stacks (); /* Requires strings, struct, frames */
- scm_init_symbols ();
- scm_init_values (); /* Requires struct */
- scm_init_load (); /* Requires strings */
- scm_init_print (); /* Requires strings, struct, smob */
- scm_init_read ();
- scm_init_strorder ();
- scm_init_srfi_13 ();
- scm_init_srfi_14 (); /* Requires smob_prehistory */
- scm_init_exceptions ();
- scm_init_throw (); /* Requires smob_prehistory */
- scm_init_version ();
- scm_init_weak_set ();
- scm_init_weak_table ();
- scm_init_weak_vectors ();
- scm_init_guardians (); /* requires smob_prehistory */
- scm_init_standard_ports (); /* Requires fports */
- scm_init_expand (); /* Requires structs */
- scm_init_memoize (); /* Requires smob_prehistory */
- scm_init_eval (); /* Requires smob_prehistory */
- scm_init_load_path ();
- scm_init_eval_in_scheme ();
- scm_init_evalext ();
- scm_init_debug (); /* Requires macro smobs */
- scm_init_simpos ();
- scm_init_syntax ();
- #if HAVE_MODULES
- scm_init_dynamic_linking (); /* Requires smob_prehistory */
- #endif
- scm_bootstrap_i18n ();
- scm_init_script ();
- scm_init_unicode ();
- #if ENABLE_JIT
- scm_init_jit ();
- #endif
- scm_init_goops ();
- #if SCM_ENABLE_DEPRECATED == 1
- scm_i_init_deprecated ();
- #endif
- scm_initialized_p = 1;
- scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
- scm_init_rdelim ();
- scm_init_rw ();
- scm_init_extensions ();
- atexit (cleanup_for_exit);
- scm_load_startup_files ();
- scm_init_load_should_auto_compile ();
- /* Capture the dynamic state after loading boot-9, so that new threads end up
- in the guile-user module. */
- scm_init_threads_default_dynamic_state ();
- /* Finally, cause finalizers to run in a separate thread. */
- scm_init_finalizer_thread ();
- }
|