mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 00:30:21 +02:00
Code Activity

* Makefile.in: Rebuilt.

Browse source 
* Makefile.am (libguile_la_SOURCES): Removed extchrs.c,
	mbstrings.c.
	(modinclude_HEADERS): Removed extchrs.h, mbstrings.h.
	* unif.c (scm_vector_set_length_x): Don't handle multibyte
	strings.
	* tag.c (scm_utag_mb_string, scm_utag_mb_substring): Removed.
	(scm_tag): Don't handle multibyte strings.
	* read.c: Don't include mbstrings.h.
	(scm_lreadr): Don't handle multibyte ports.
	* kw.c: Don't include mbstrings.h.
	* init.c: Don't include mbstrings.h.
	(scm_boot_guile_1): Don't init mbstrings module.
	* hash.c (scm_hasher): Don't handle mbstrings.
	* gscm.c (gscm_run_scm): Don't init mbstrings module.
	* gc.c (scm_gc_mark): Don't handle mbstrings.
	(scm_gc_sweep): Likewise.
	* eval.c (SCM_CEVAL): Don't handle mbstrings.
	* eq.c (scm_equal_p): Use SCM_TYP7S, not SCM_TYP7SD.
	* tags.h (SCM_TYP7SD): Removed.
	(SCM_TYP7D): Removed.
	(scm_tc7_mb_string): Removed.
	(scm_tc7_mb_substring): Removed.
	* print.c (scm_iprin1): Handle char printing directly.  Don't
	handle mbstrings.
	Don't include "mbstrings.h".
	* symbols.c (scm_intern_obarray_soft, scm_string_to_symbol,
	scm_string_to_obarray_symbol, msymbolize): Don't set symbol's
	multi-byte flag.
	Don't include "mbstrings.h".
	* symbols.h (SCM_SYMBOL_MULTI_BYTE_STRINGP): Removed.
	(SCM_SYMBOL_SLOTS): Define as 4.
	(SCM_ROSTRINGP): Use SCM_TYP7S, not SCM_TYP7SD.
	* arbiters.c, backtrace.c, debug.c, dynl.c, eval.c, fluids.c,
	gc.c, gsubr.c, ioext.c, kw.c, mallocs.c, numbers.c, ports.c,
	print.c, read.c, regex-posix.c, root.c, srcprop.c, stackchk.c,
	struct.c, threads.c, throw.c, unif.c, variable.c: Use new
	("gen"-less) I/O function names.
	* ports.c (scm_add_to_port_table): Don't set port's
	representation.
	* ports.h (scm_port_representation_type): Removed.
	(scm_string_representation_type): Removed.
	(struct scm_port_table ): Removed representation field.
	(SCM_PORT_REPRESENTATION): Removed.
	(SCM_SET_PORT_REPRESENTATION): Removed.
	* genio.h: Use new function names.
	* genio.c: Don't include "extchrs.h".
	(scm_gen_putc, scm_gen_puts, scm_gen_write, scm_get_getc):
	Removed.
	(scm_putc, scm_puts, scm_lfwrite): No longer static.
	(scm_getc): No longer static; handle line and column changes.
	(scm_ungetc): Renamed from scm_gen_ungetc.
	(scm_do_read_line): Renamed from scm_gen_read_line.
	* libguile.h: Don't include "extchrs.h" or "mbstrings.h"
	* extchrs.h, extchrs.c, mbstrings.h, mbstrings.c: Removed.
This commit is contained in:
Tom Tromey 1997-10-15 17:18:32 +00:00
parent 8d6787b6dc
commit b7f3516f99
46 changed files with 402 additions and 1447 deletions
Download patch file Download diff file Expand all files Collapse all files

594
libguile/gscm.c
View file

@ -1,594 +0,0 @@
/* Copyright (C) 1994, 1995, 1996 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, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* The exception is that, if you link the GUILE library with other files
* to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the GUILE library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the
* Free Software Foundation under the name GUILE. If you copy
* code from other Free Software Foundation releases into a copy of
* GUILE, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* 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. */
#include <stdio.h>
#include <sys/param.h>
#include "gscm.h"
#include "_scm.h"
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef HAVE_STRING_H
#include <string.h>
#endif
extern char *getenv ();
/* {Top Level Evaluation}
*
* Top level evaluation has to establish a dynamic root context,
* enable Scheme signal handlers, and catch global escapes (errors, quits,
* aborts, restarts, and execs) from the interpreter.
*/
/* {Printing Objects to Strings}
*/
static GSCM_status gscm_portprint_obj SCM_P ((SCM port, SCM obj));
static GSCM_status
gscm_portprint_obj (port, obj)
SCM port;
SCM obj;
{
scm_prin1 (obj, port, 1);
return GSCM_OK;
}
struct seval_str_frame
{
GSCM_status status;
SCM * answer;
GSCM_top_level top;
char * str;
};
static void _seval_str_fn SCM_P ((void * vframe));
static void
_seval_str_fn (vframe)
void * vframe;
{
struct seval_str_frame * frame;
frame = (struct seval_str_frame *)vframe;
frame->status = gscm_seval_str (frame->answer, frame->top, frame->str);
}
static GSCM_status gscm_strprint_obj SCM_P ((SCM * answer, SCM obj));
static GSCM_status
gscm_strprint_obj (answer, obj)
SCM * answer;
SCM obj;
{
SCM str;
SCM port;
GSCM_status stat;
str = scm_makstr (64, 0);
port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "gscm_strprint_obj");
stat = gscm_portprint_obj (port, obj);
if (stat == GSCM_OK)
*answer = str;
else
*answer = SCM_BOOL_F;
return stat;
}
static GSCM_status gscm_cstr SCM_P ((char ** answer, SCM obj));
static GSCM_status
gscm_cstr (answer, obj)
char ** answer;
SCM obj;
{
GSCM_status stat;
*answer = (char *)malloc (SCM_LENGTH (obj));
stat = GSCM_OK;
if (!*answer)
stat = GSCM_OUT_OF_MEM;
else
memcpy (*answer, SCM_CHARS (obj), SCM_LENGTH (obj));
return stat;
}
/* {Invoking The Interpreter}
*/
static SCM gscm_silent_repl SCM_P ((SCM env));
static SCM
gscm_silent_repl (env)
SCM env;
{
SCM source;
SCM answer;
answer = SCM_UNSPECIFIED;
while ((source = scm_read (SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED)) != SCM_EOF_VAL)
answer = scm_eval_x (source);
return answer;
}
#ifdef _UNICOS
typedef int setjmp_type;
#else
typedef long setjmp_type;
#endif
static GSCM_status _eval_port SCM_P ((SCM * answer, GSCM_top_level toplvl, SCM port, int printp));
static GSCM_status
_eval_port (answer, toplvl, port, printp)
SCM * answer;
GSCM_top_level toplvl;
SCM port;
int printp;
{
SCM saved_inp;
GSCM_status status;
setjmp_type i;
static int deja_vu = 0;
SCM ignored;
if (deja_vu)
return GSCM_ILLEGALLY_REENTERED;
++deja_vu;
/* Take over signal handlers for all the interesting signals.
*/
scm_init_signals ();
/* Default return values:
*/
if (!answer)
answer = &ignored;
status = GSCM_OK;
*answer = SCM_BOOL_F;
/* Perform evalutation under a new dynamic root.
*
*/
SCM_BASE (scm_rootcont) = (SCM_STACKITEM *) & i;
#ifdef DEBUG_EXTENSIONS
SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
#endif
saved_inp = scm_cur_inp;
i = setjmp (SCM_JMPBUF (scm_rootcont));
#ifdef STACK_CHECKING
scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
#endif
if (!i)
{
scm_gc_heap_lock = 0;
scm_ints_disabled = 0;
/* need to close loading files here. */
scm_cur_inp = port;
{
SCM top_env;
top_env = SCM_EOL;
*answer = gscm_silent_repl (top_env);
}
scm_cur_inp = saved_inp;
if (printp)
status = gscm_strprint_obj (answer, *answer);
}
else
{
scm_cur_inp = saved_inp;
*answer = scm_exitval;
if (printp)
gscm_strprint_obj (answer, *answer);
status = GSCM_ERROR;
}
scm_gc_heap_lock = 1;
scm_ints_disabled = 1;
scm_restore_signals ();
--deja_vu;
return status;
}
static GSCM_status seval_str SCM_P ((SCM *answer, GSCM_top_level toplvl, char * str));
static GSCM_status
seval_str (answer, toplvl, str)
SCM *answer;
GSCM_top_level toplvl;
char * str;
{
SCM scheme_str;
SCM port;
GSCM_status status;
scheme_str = scm_makfromstr (str, strlen (str), 0);
port = scm_mkstrport (SCM_MAKINUM (0), scheme_str, SCM_OPN | SCM_RDNG, "gscm_seval_str");
status = _eval_port (answer, toplvl, port, 0);
return status;
}
GSCM_status
gscm_seval_str (answer, toplvl, str)
SCM *answer;
GSCM_top_level toplvl;
char * str;
{
SCM_STACKITEM i;
GSCM_status status;
scm_stack_base = &i;
status = seval_str (answer, toplvl, str);
scm_stack_base = 0;
return status;
}
void
format_load_command (buf, file_name)
char * buf;
char *file_name;
{
char quoted_name[MAXPATHLEN + 1];
int source;
int dest;
for (source = dest = 0; file_name[source]; ++source)
{
if (file_name[source] == '"')
quoted_name[dest++] = '\\';
quoted_name[dest++] = file_name[source];
}
quoted_name[dest] = 0;
sprintf (buf, "(%%try-load \"%s\")", quoted_name);
}
GSCM_status
gscm_seval_file (answer, toplvl, file_name)
SCM *answer;
GSCM_top_level toplvl;
char * file_name;
{
char command[MAXPATHLEN * 3];
format_load_command (command, file_name);
return gscm_seval_str (answer, toplvl, command);
}
static GSCM_status eval_str SCM_P ((char ** answer, GSCM_top_level toplvl, char * str));
static GSCM_status
eval_str (answer, toplvl, str)
char ** answer;
GSCM_top_level toplvl;
char * str;
{
SCM sanswer;
SCM scheme_str;
SCM port;
GSCM_status status;
scheme_str = scm_makfromstr (str, strlen (str), 0);
port = scm_mkstrport (SCM_MAKINUM(0), scheme_str, SCM_OPN | SCM_RDNG, "gscm_eval_str");
status = _eval_port (&sanswer, toplvl, port, 1);
if (answer)
{
if (status == GSCM_OK)
status = gscm_cstr (answer, sanswer);
else
*answer = 0;
}
return status;
}
GSCM_status
gscm_eval_str (answer, toplvl, str)
char ** answer;
GSCM_top_level toplvl;
char * str;
{
SCM_STACKITEM i;
GSCM_status status;
scm_stack_base = &i;
status = eval_str (answer, toplvl, str);
scm_stack_base = 0;
return status;
}
GSCM_status
gscm_eval_file (answer, toplvl, file_name)
char ** answer;
GSCM_top_level toplvl;
char * file_name;
{
char command[MAXPATHLEN * 3];
format_load_command (command, file_name);
return gscm_eval_str (answer, toplvl, command);
}
/* {Error Messages}
*/
#ifdef __GNUC__
# define AT(X) [X] =
#else
# define AT(X)
#endif
static char * gscm_error_msgs[] =
{
AT(GSCM_OK) "No error.",
AT(GSCM_ERROR) "ERROR in init file.",
AT(GSCM_ILLEGALLY_REENTERED) "Gscm function was illegally reentered.",
AT(GSCM_OUT_OF_MEM) "Out of memory.",
AT(GSCM_ERROR_OPENING_FILE) "Error opening file.",
AT(GSCM_ERROR_OPENING_INIT_FILE) "Error opening init file."
};
char *
gscm_error_msg (n)
int n;
{
if ((n < 0) || (n > (sizeof (gscm_error_msgs) / sizeof (char *))))
return "Unrecognized error.";
else
return gscm_error_msgs[n];
}
/* {Defining New Procedures}
*/
SCM
gscm_make_subr (fn, req, opt, varp, doc)
SCM (*fn)();
int req;
int opt;
int varp;
char * doc;
{
return scm_make_gsubr ("*anonymous*", req, opt, varp, fn);
}
int
gscm_2_char (c)
SCM c;
{
SCM_ASSERT (SCM_ICHRP (c), c, SCM_ARG1, "gscm_2_char");
return SCM_ICHR (c);
}
void
gscm_2_str (out, len_out, objp)
char ** out;
int * len_out;
SCM * objp;
{
SCM_ASSERT (SCM_NIMP (*objp) && SCM_STRINGP (*objp), *objp, SCM_ARG3, "gscm_2_str");
if (out)
*out = SCM_CHARS (*objp);
if (len_out)
*len_out = SCM_LENGTH (*objp);
}
void
gscm_error (message, args)
char * message;
SCM args;
{
SCM errsym;
SCM str;
errsym = SCM_CAR (scm_intern ("error", 5));
str = scm_makfrom0str (message);
scm_throw (errsym, scm_cons (str, args));
}
GSCM_status
gscm_run_scm (argc, argv, in, out, err, initfn, initfile, initcmd)
int argc;
char ** argv;
FILE * in;
FILE * out;
FILE * err;
GSCM_status (*initfn)();
char * initfile;
char * initcmd;
{
SCM_STACKITEM i;
GSCM_status status;
GSCM_top_level top;
scm_ports_prehistory ();
scm_smob_prehistory ();
scm_tables_prehistory ();
scm_init_storage (0);
scm_start_stack (&i, in, out, err);
scm_init_gsubr ();
scm_init_curry ();
scm_init_feature ();
/* scm_init_debug (); */
scm_init_alist ();
scm_init_append ();
scm_init_arbiters ();
scm_init_async ();
scm_init_boolean ();
scm_init_chars ();
scm_init_continuations ();
scm_init_dynwind ();
scm_init_eq ();
scm_init_error ();
scm_init_fports ();
scm_init_files ();
scm_init_gc ();
scm_init_hash ();
scm_init_hashtab ();
scm_init_kw ();
scm_init_list ();
scm_init_lvectors ();
scm_init_numbers ();
scm_init_pairs ();
scm_init_ports ();
scm_init_procs ();
scm_init_procprop ();
scm_init_scmsigs ();
scm_init_stackchk ();
scm_init_strports ();
scm_init_struct ();
scm_init_symbols ();
scm_init_load ();
scm_init_print ();
scm_init_read ();
scm_init_sequences ();
scm_init_stime ();
scm_init_strings ();
scm_init_strorder ();
scm_init_mbstrings ();
scm_init_strop ();
scm_init_throw ();
scm_init_variable ();
scm_init_vectors ();
scm_init_version ();
scm_init_weaks ();
scm_init_vports ();
scm_init_eval ();
scm_init_ramap ();
scm_init_unif ();
scm_init_simpos ();
scm_init_elisp ();
scm_init_mallocs ();
scm_init_cnsvobj ();
scm_init_guile ();
initfn ();
/* Save the argument list to be the return value of (program-arguments).
*/
scm_progargs = scm_makfromstrs (argc, argv);
scm_gc_heap_lock = 0;
errno = 0;
scm_ints_disabled = 1;
/* init_basic (); */
/* init_init(); */
if (initfile == NULL)
{
initfile = getenv ("GUILE_INIT_PATH");
if (initfile == NULL)
initfile = SCM_IMPLINIT;
}
if (initfile == NULL)
{
status = GSCM_OK;
}
else
{
SCM answer;
status = gscm_seval_file (&answer, -1, initfile);
if ((status == GSCM_OK) && (answer == SCM_BOOL_F))
status = GSCM_ERROR_OPENING_INIT_FILE;
}
top = SCM_EOL;
if (status == GSCM_OK)
{
scm_sysintern ("*stdin*", scm_cur_inp);
status = gscm_seval_str (0, top, initcmd);
}
return status;
}
void
scm_init_guile ()
{
#include "gscm.x"
}