mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +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

58
libguile/ChangeLog
View file

@ -1,3 +1,61 @@
Tue Oct 14 22:03:06 1997 Tom Tromey <tromey@cygnus.com>
* Makefile.in: Rebuilt.
* 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.
1997-10-12 Mark Galassi <rosalia@cygnus.com> 1997-10-12 Mark Galassi <rosalia@cygnus.com>
* gh_test_repl.c (c_vector_test): same as gh_test_c.c * gh_test_repl.c (c_vector_test): same as gh_test_c.c

8
libguile/Makefile.am
View file

@ -17,11 +17,11 @@ guile_LDADD = libguile.la ${THREAD_LIBS}
libguile_la_SOURCES = \ libguile_la_SOURCES = \
alist.c appinit.c arbiters.c async.c boolean.c chars.c \ alist.c appinit.c arbiters.c async.c boolean.c chars.c \
continuations.c dynl.c dynwind.c eq.c error.c eval.c extchrs.c \ continuations.c dynl.c dynwind.c eq.c error.c eval.c \
feature.c filesys.c fports.c gc.c gdbint.c genio.c gh_data.c gh_eval.c \ feature.c filesys.c fports.c gc.c gdbint.c genio.c gh_data.c gh_eval.c \
gh_funcs.c gh_init.c gh_io.c gh_list.c gh_predicates.c gsubr.c hash.c \ gh_funcs.c gh_init.c gh_io.c gh_list.c gh_predicates.c gsubr.c hash.c \
hashtab.c init.c ioext.c kw.c list.c load.c mallocs.c markers.c \ hashtab.c init.c ioext.c kw.c list.c load.c mallocs.c markers.c \
mbstrings.c net_db.c numbers.c objects.c objprop.c options.c pairs.c \ net_db.c numbers.c objects.c objprop.c options.c pairs.c \
ports.c posix.c print.c procprop.c procs.c ramap.c read.c root.c \ ports.c posix.c print.c procprop.c procs.c ramap.c read.c root.c \
scmsigs.c script.c simpos.c smob.c socket.c stackchk.c stime.c \ scmsigs.c script.c simpos.c smob.c socket.c stackchk.c stime.c \
strings.c strop.c strorder.c strports.c struct.c symbols.c tag.c \ strings.c strop.c strorder.c strports.c struct.c symbols.c tag.c \
@ -53,9 +53,9 @@ pkginclude_HEADERS = gh.h
modincludedir = $(includedir)/libguile modincludedir = $(includedir)/libguile
modinclude_HEADERS = __scm.h alist.h arbiters.h async.h \ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h \
backtrace.h boolean.h chars.h continuations.h debug.h dynl.h dynwind.h \ backtrace.h boolean.h chars.h continuations.h debug.h dynl.h dynwind.h \
eq.h error.h eval.h extchrs.h feature.h filesys.h fports.h gc.h \ eq.h error.h eval.h feature.h filesys.h fports.h gc.h \
gdb_interface.h gdbint.h genio.h gsubr.h hash.h hashtab.h init.h \ gdb_interface.h gdbint.h genio.h gsubr.h hash.h hashtab.h init.h \
ioext.h kw.h list.h load.h mallocs.h markers.h mbstrings.h net_db.h \ ioext.h kw.h list.h load.h mallocs.h markers.h net_db.h \
numbers.h objects.h objprop.h options.h pairs.h ports.h posix.h \ numbers.h objects.h objprop.h options.h pairs.h ports.h posix.h \
regex-posix.h print.h procprop.h procs.h ramap.h read.h root.h scmsigs.h \ regex-posix.h print.h procprop.h procs.h ramap.h read.h root.h scmsigs.h \
script.h simpos.h smob.h socket.h srcprop.h stackchk.h stacks.h \ script.h simpos.h smob.h socket.h srcprop.h stackchk.h stacks.h \

60
libguile/Makefile.in
View file

@ -96,11 +96,11 @@ guile_LDADD = libguile.la ${THREAD_LIBS}
libguile_la_SOURCES = \ libguile_la_SOURCES = \
alist.c appinit.c arbiters.c async.c boolean.c chars.c \ alist.c appinit.c arbiters.c async.c boolean.c chars.c \
continuations.c dynl.c dynwind.c eq.c error.c eval.c extchrs.c \ continuations.c dynl.c dynwind.c eq.c error.c eval.c \
feature.c filesys.c fports.c gc.c gdbint.c genio.c gh_data.c gh_eval.c \ feature.c filesys.c fports.c gc.c gdbint.c genio.c gh_data.c gh_eval.c \
gh_funcs.c gh_init.c gh_io.c gh_list.c gh_predicates.c gsubr.c hash.c \ gh_funcs.c gh_init.c gh_io.c gh_list.c gh_predicates.c gsubr.c hash.c \
hashtab.c init.c ioext.c kw.c list.c load.c mallocs.c markers.c \ hashtab.c init.c ioext.c kw.c list.c load.c mallocs.c markers.c \
mbstrings.c net_db.c numbers.c objects.c objprop.c options.c pairs.c \ net_db.c numbers.c objects.c objprop.c options.c pairs.c \
ports.c posix.c print.c procprop.c procs.c ramap.c read.c root.c \ ports.c posix.c print.c procprop.c procs.c ramap.c read.c root.c \
scmsigs.c script.c simpos.c smob.c socket.c stackchk.c stime.c \ scmsigs.c script.c simpos.c smob.c socket.c stackchk.c stime.c \
strings.c strop.c strorder.c strports.c struct.c symbols.c tag.c \ strings.c strop.c strorder.c strports.c struct.c symbols.c tag.c \
@ -128,9 +128,9 @@ pkginclude_HEADERS = gh.h
modincludedir = $(includedir)/libguile modincludedir = $(includedir)/libguile
modinclude_HEADERS = __scm.h alist.h arbiters.h async.h \ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h \
backtrace.h boolean.h chars.h continuations.h debug.h dynl.h dynwind.h \ backtrace.h boolean.h chars.h continuations.h debug.h dynl.h dynwind.h \
eq.h error.h eval.h extchrs.h feature.h filesys.h fports.h gc.h \ eq.h error.h eval.h feature.h filesys.h fports.h gc.h \
gdb_interface.h gdbint.h genio.h gsubr.h hash.h hashtab.h init.h \ gdb_interface.h gdbint.h genio.h gsubr.h hash.h hashtab.h init.h \
ioext.h kw.h list.h load.h mallocs.h markers.h mbstrings.h net_db.h \ ioext.h kw.h list.h load.h mallocs.h markers.h net_db.h \
numbers.h objects.h objprop.h options.h pairs.h ports.h posix.h \ numbers.h objects.h objprop.h options.h pairs.h ports.h posix.h \
regex-posix.h print.h procprop.h procs.h ramap.h read.h root.h scmsigs.h \ regex-posix.h print.h procprop.h procs.h ramap.h read.h root.h scmsigs.h \
script.h simpos.h smob.h socket.h srcprop.h stackchk.h stacks.h \ script.h simpos.h smob.h socket.h srcprop.h stackchk.h stacks.h \
@ -178,16 +178,15 @@ LDFLAGS = @LDFLAGS@
LIBS = @LIBS@ LIBS = @LIBS@
libguile_la_OBJECTS = alist.lo appinit.lo arbiters.lo async.lo \ libguile_la_OBJECTS = alist.lo appinit.lo arbiters.lo async.lo \
boolean.lo chars.lo continuations.lo dynl.lo dynwind.lo eq.lo error.lo \ boolean.lo chars.lo continuations.lo dynl.lo dynwind.lo eq.lo error.lo \
eval.lo extchrs.lo feature.lo filesys.lo fports.lo gc.lo gdbint.lo \ eval.lo feature.lo filesys.lo fports.lo gc.lo gdbint.lo genio.lo \
genio.lo gh_data.lo gh_eval.lo gh_funcs.lo gh_init.lo gh_io.lo \ gh_data.lo gh_eval.lo gh_funcs.lo gh_init.lo gh_io.lo gh_list.lo \
gh_list.lo gh_predicates.lo gsubr.lo hash.lo hashtab.lo init.lo \ gh_predicates.lo gsubr.lo hash.lo hashtab.lo init.lo ioext.lo kw.lo \
ioext.lo kw.lo list.lo load.lo mallocs.lo markers.lo mbstrings.lo \ list.lo load.lo mallocs.lo markers.lo net_db.lo numbers.lo objects.lo \
net_db.lo numbers.lo objects.lo objprop.lo options.lo pairs.lo ports.lo \ objprop.lo options.lo pairs.lo ports.lo posix.lo print.lo procprop.lo \
posix.lo print.lo procprop.lo procs.lo ramap.lo read.lo root.lo \ procs.lo ramap.lo read.lo root.lo scmsigs.lo script.lo simpos.lo \
scmsigs.lo script.lo simpos.lo smob.lo socket.lo stackchk.lo stime.lo \ smob.lo socket.lo stackchk.lo stime.lo strings.lo strop.lo strorder.lo \
strings.lo strop.lo strorder.lo strports.lo struct.lo symbols.lo tag.lo \ strports.lo struct.lo symbols.lo tag.lo throw.lo unif.lo variable.lo \
throw.lo unif.lo variable.lo vectors.lo version.lo vports.lo weaks.lo \ vectors.lo version.lo vports.lo weaks.lo fluids.lo
fluids.lo
PROGRAMS = $(bin_PROGRAMS) PROGRAMS = $(bin_PROGRAMS)
guile_OBJECTS = guile.o guile_OBJECTS = guile.o
@ -221,23 +220,22 @@ GZIP = --best
DEP_FILES = .deps/alist.P .deps/alloca.P .deps/appinit.P \ DEP_FILES = .deps/alist.P .deps/alloca.P .deps/appinit.P \
.deps/arbiters.P .deps/async.P .deps/backtrace.P .deps/boolean.P \ .deps/arbiters.P .deps/async.P .deps/backtrace.P .deps/boolean.P \
.deps/chars.P .deps/continuations.P .deps/debug.P .deps/dynl.P \ .deps/chars.P .deps/continuations.P .deps/debug.P .deps/dynl.P \
.deps/dynwind.P .deps/eq.P .deps/error.P .deps/eval.P .deps/extchrs.P \ .deps/dynwind.P .deps/eq.P .deps/error.P .deps/eval.P .deps/feature.P \
.deps/feature.P .deps/filesys.P .deps/fluids.P .deps/fports.P \ .deps/filesys.P .deps/fluids.P .deps/fports.P .deps/gc.P .deps/gdbint.P \
.deps/gc.P .deps/gdbint.P .deps/genio.P .deps/gh_data.P .deps/gh_eval.P \ .deps/genio.P .deps/gh_data.P .deps/gh_eval.P .deps/gh_funcs.P \
.deps/gh_funcs.P .deps/gh_init.P .deps/gh_io.P .deps/gh_list.P \ .deps/gh_init.P .deps/gh_io.P .deps/gh_list.P .deps/gh_predicates.P \
.deps/gh_predicates.P .deps/gh_test_c.P .deps/gh_test_repl.P \ .deps/gh_test_c.P .deps/gh_test_repl.P .deps/gsubr.P .deps/guile.P \
.deps/gsubr.P .deps/guile.P .deps/hash.P .deps/hashtab.P \ .deps/hash.P .deps/hashtab.P .deps/inet_aton.P .deps/init.P \
.deps/inet_aton.P .deps/init.P .deps/ioext.P .deps/kw.P .deps/list.P \ .deps/ioext.P .deps/kw.P .deps/list.P .deps/load.P .deps/mallocs.P \
.deps/load.P .deps/mallocs.P .deps/markers.P .deps/mbstrings.P \ .deps/markers.P .deps/net_db.P .deps/numbers.P .deps/objects.P \
.deps/net_db.P .deps/numbers.P .deps/objects.P .deps/objprop.P \ .deps/objprop.P .deps/options.P .deps/pairs.P .deps/ports.P \
.deps/options.P .deps/pairs.P .deps/ports.P .deps/posix.P .deps/print.P \ .deps/posix.P .deps/print.P .deps/procprop.P .deps/procs.P \
.deps/procprop.P .deps/procs.P .deps/putenv.P .deps/ramap.P \ .deps/putenv.P .deps/ramap.P .deps/read.P .deps/regex-posix.P \
.deps/read.P .deps/regex-posix.P .deps/root.P .deps/scmsigs.P \ .deps/root.P .deps/scmsigs.P .deps/script.P .deps/simpos.P .deps/smob.P \
.deps/script.P .deps/simpos.P .deps/smob.P .deps/socket.P \ .deps/socket.P .deps/srcprop.P .deps/stackchk.P .deps/stacks.P \
.deps/srcprop.P .deps/stackchk.P .deps/stacks.P .deps/stime.P \ .deps/stime.P .deps/strerror.P .deps/strings.P .deps/strop.P \
.deps/strerror.P .deps/strings.P .deps/strop.P .deps/strorder.P \ .deps/strorder.P .deps/strports.P .deps/struct.P .deps/symbols.P \
.deps/strports.P .deps/struct.P .deps/symbols.P .deps/tag.P \ .deps/tag.P .deps/threads.P .deps/throw.P .deps/unif.P .deps/variable.P \
.deps/threads.P .deps/throw.P .deps/unif.P .deps/variable.P \
.deps/vectors.P .deps/version.P .deps/vports.P .deps/weaks.P .deps/vectors.P .deps/version.P .deps/vports.P .deps/weaks.P
SOURCES = $(libguile_la_SOURCES) $(EXTRA_libguile_la_SOURCES) $(guile_SOURCES) $(gh_test_c_SOURCES) $(gh_test_repl_SOURCES) SOURCES = $(libguile_la_SOURCES) $(EXTRA_libguile_la_SOURCES) $(guile_SOURCES) $(gh_test_c_SOURCES) $(gh_test_repl_SOURCES)
OBJECTS = $(libguile_la_OBJECTS) $(guile_OBJECTS) $(gh_test_c_OBJECTS) $(gh_test_repl_OBJECTS) OBJECTS = $(libguile_la_OBJECTS) $(guile_OBJECTS) $(gh_test_c_OBJECTS) $(gh_test_repl_OBJECTS)

8
libguile/arbiters.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996 Free Software Foundation, Inc. /* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -63,11 +63,11 @@ prinarb (exp, port, pstate)
SCM port; SCM port;
scm_print_state *pstate; scm_print_state *pstate;
{ {
scm_gen_puts (scm_regular_string, "#<arbiter ", port); scm_puts ("#<arbiter ", port);
if (SCM_CAR (exp) & (1L << 16)) if (SCM_CAR (exp) & (1L << 16))
scm_gen_puts (scm_regular_string, "locked ", port); scm_puts ("locked ", port);
scm_iprin1 (SCM_CDR (exp), port, pstate); scm_iprin1 (SCM_CDR (exp), port, pstate);
scm_gen_putc ('>', port); scm_putc ('>', port);
return !0; return !0;
} }

4
libguile/async.c
View file

@ -273,9 +273,9 @@ print_async (exp, port, pstate)
SCM port; SCM port;
scm_print_state *pstate; scm_print_state *pstate;
{ {
scm_gen_puts (scm_regular_string, "#<async ", port); scm_puts ("#<async ", port);
scm_intprint(exp, 16, port); scm_intprint(exp, 16, port);
scm_gen_putc('>', port); scm_putc('>', port);
return 1; return 1;
} }

57
libguile/backtrace.c
View file

@ -79,14 +79,14 @@ display_header (source, port)
if (SCM_NIMP (fname) && SCM_STRINGP (fname)) if (SCM_NIMP (fname) && SCM_STRINGP (fname))
{ {
scm_prin1 (fname, port, 0); scm_prin1 (fname, port, 0);
scm_gen_putc (':', port); scm_putc (':', port);
scm_prin1 (scm_source_property (source, scm_i_line), port, 0); scm_prin1 (scm_source_property (source, scm_i_line), port, 0);
scm_gen_putc (':', port); scm_putc (':', port);
scm_prin1 (scm_source_property (source, scm_i_column), port, 0); scm_prin1 (scm_source_property (source, scm_i_column), port, 0);
} }
else else
scm_gen_puts (scm_regular_string, "ERROR", port); scm_puts ("ERROR", port);
scm_gen_puts (scm_regular_string, ": ", port); scm_puts (": ", port);
} }
@ -104,7 +104,7 @@ scm_display_error_message (message, args, port)
|| !scm_list_p (args)) || !scm_list_p (args))
{ {
scm_prin1 (message, port, 0); scm_prin1 (message, port, 0);
scm_gen_putc ('\n', port); scm_putc ('\n', port);
return; return;
} }
@ -124,13 +124,13 @@ scm_display_error_message (message, args, port)
else else
continue; continue;
scm_gen_write (scm_regular_string, start, p - start - 1, port); scm_lfwrite (start, p - start - 1, port);
scm_prin1 (SCM_CAR (args), port, writingp); scm_prin1 (SCM_CAR (args), port, writingp);
args = SCM_CDR (args); args = SCM_CDR (args);
start = p + 1; start = p + 1;
} }
scm_gen_write (scm_regular_string, start, p - start, port); scm_lfwrite (start, p - start, port);
scm_gen_putc ('\n', port); scm_putc ('\n', port);
} }
static void display_expression SCM_P ((SCM frame, SCM pname, SCM source, SCM port)); static void display_expression SCM_P ((SCM frame, SCM pname, SCM source, SCM port));
@ -152,24 +152,24 @@ display_expression (frame, pname, source, port)
if (SCM_NIMP (frame) if (SCM_NIMP (frame)
&& SCM_FRAMEP (frame) && SCM_FRAMEP (frame)
&& SCM_FRAME_EVAL_ARGS_P (frame)) && SCM_FRAME_EVAL_ARGS_P (frame))
scm_gen_puts (scm_regular_string, "While evaluating arguments to ", port); scm_puts ("While evaluating arguments to ", port);
else else
scm_gen_puts (scm_regular_string, "In procedure ", port); scm_puts ("In procedure ", port);
scm_iprin1 (pname, port, pstate); scm_iprin1 (pname, port, pstate);
if (SCM_NIMP (source) && SCM_MEMOIZEDP (source)) if (SCM_NIMP (source) && SCM_MEMOIZEDP (source))
{ {
scm_gen_puts (scm_regular_string, " in expression ", port); scm_puts (" in expression ", port);
pstate->writingp = 1; pstate->writingp = 1;
scm_iprin1 (scm_unmemoize (source), port, pstate); scm_iprin1 (scm_unmemoize (source), port, pstate);
} }
} }
else if (SCM_NIMP (source)) else if (SCM_NIMP (source))
{ {
scm_gen_puts (scm_regular_string, "In expression ", port); scm_puts ("In expression ", port);
pstate->writingp = 1; pstate->writingp = 1;
scm_iprin1 (scm_unmemoize (source), port, pstate); scm_iprin1 (scm_unmemoize (source), port, pstate);
} }
scm_gen_puts (scm_regular_string, ":\n", port); scm_puts (":\n", port);
scm_free_print_state (print_state); scm_free_print_state (print_state);
} }
@ -229,13 +229,11 @@ display_error_handler (struct display_error_handler_data *data,
SCM tag, SCM args) SCM tag, SCM args)
{ {
SCM print_state = scm_make_print_state (); SCM print_state = scm_make_print_state ();
scm_gen_puts (scm_regular_string, scm_puts ("\nException during displaying of ", data->port);
"\nException during displaying of ", scm_puts (data->mode, data->port);
data->port); scm_puts (": ", data->port);
scm_gen_puts (scm_regular_string, data->mode, data->port);
scm_gen_puts (scm_regular_string, ": ", data->port);
scm_iprin1 (tag, data->port, SCM_PRINT_STATE (print_state)); scm_iprin1 (tag, data->port, SCM_PRINT_STATE (print_state));
scm_gen_putc ('\n', data->port); scm_putc ('\n', data->port);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
@ -265,7 +263,7 @@ indent (n, port)
{ {
int i; int i;
for (i = 0; i < n; ++i) for (i = 0; i < n; ++i)
scm_gen_putc (' ', port); scm_putc (' ', port);
} }
static void display_frame_expr SCM_P ((char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate)); static void display_frame_expr SCM_P ((char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate));
@ -282,11 +280,11 @@ display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate)
if (SCM_NIMP (exp) && SCM_CONSP (exp)) if (SCM_NIMP (exp) && SCM_CONSP (exp))
{ {
scm_iprlist (hdr, exp, tlr[0], port, pstate); scm_iprlist (hdr, exp, tlr[0], port, pstate);
scm_gen_puts (scm_regular_string, &tlr[1], port); scm_puts (&tlr[1], port);
} }
else else
scm_iprin1 (exp, port, pstate); scm_iprin1 (exp, port, pstate);
scm_gen_putc ('\n', port); scm_putc ('\n', port);
} }
static void display_application SCM_P ((SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate)); static void display_application SCM_P ((SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate));
@ -356,7 +354,7 @@ display_frame (frame, nfield, indentation, sport, port, pstate)
if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame)) if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
{ {
indent (nfield + 1 + indentation, port); indent (nfield + 1 + indentation, port);
scm_gen_puts (scm_regular_string, "...\n", port); scm_puts ("...\n", port);
} }
/* Check size of frame number. */ /* Check size of frame number. */
@ -370,7 +368,7 @@ display_frame (frame, nfield, indentation, sport, port, pstate)
scm_iprin1 (SCM_MAKINUM (n), port, pstate); scm_iprin1 (SCM_MAKINUM (n), port, pstate);
/* Real frame marker */ /* Real frame marker */
scm_gen_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port); scm_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
/* Indentation. */ /* Indentation. */
indent (indentation, port); indent (indentation, port);
@ -398,7 +396,7 @@ display_frame (frame, nfield, indentation, sport, port, pstate)
if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame)) if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
{ {
indent (nfield + 1 + indentation, port); indent (nfield + 1 + indentation, port);
scm_gen_puts (scm_regular_string, "...\n", port); scm_puts ("...\n", port);
} }
} }
@ -500,7 +498,7 @@ display_backtrace_body (struct display_backtrace_args *a, SCM jmpbuf)
for (i = 0; j > 0; ++i) j /= 10; for (i = 0; j > 0; ++i) j /= 10;
nfield = i ? i : 1; nfield = i ? i : 1;
scm_gen_puts (scm_regular_string, "Backtrace:\n", a->port); scm_puts ("Backtrace:\n", a->port);
/* Print frames. */ /* Print frames. */
frame = scm_stack_ref (a->stack, SCM_MAKINUM (beg)); frame = scm_stack_ref (a->stack, SCM_MAKINUM (beg));
@ -549,8 +547,7 @@ scm_backtrace ()
if (SCM_FALSEP (SCM_CDR (scm_has_shown_backtrace_hint_p_var)) if (SCM_FALSEP (SCM_CDR (scm_has_shown_backtrace_hint_p_var))
&& !SCM_BACKTRACE_P) && !SCM_BACKTRACE_P)
{ {
scm_gen_puts (scm_regular_string, scm_puts ("Type \"(debug-enable 'backtrace)\" if you would like "
"Type \"(debug-enable 'backtrace)\" if you would like "
"a backtrace\n" "a backtrace\n"
"automatically if an error occurs in the future.\n", "automatically if an error occurs in the future.\n",
scm_cur_outp); scm_cur_outp);
@ -559,9 +556,7 @@ scm_backtrace ()
} }
else else
{ {
scm_gen_puts (scm_regular_string, scm_puts ("No backtrace available.\n", scm_cur_outp);
"No backtrace available.\n",
scm_cur_outp);
} }
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }

10
libguile/debug.c
View file

@ -1,5 +1,5 @@
/* Debugging extensions for Guile /* Debugging extensions for Guile
* Copyright (C) 1995, 1996 Free Software Foundation * Copyright (C) 1995, 1996, 1997 Free Software Foundation
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -140,11 +140,11 @@ prinmemoized (obj, port, pstate)
scm_print_state *pstate; scm_print_state *pstate;
{ {
int writingp = SCM_WRITINGP (pstate); int writingp = SCM_WRITINGP (pstate);
scm_gen_puts (scm_regular_string, "#<memoized ", port); scm_puts ("#<memoized ", port);
SCM_SET_WRITINGP (pstate, 1); SCM_SET_WRITINGP (pstate, 1);
scm_iprin1 (scm_unmemoize (obj), port, pstate); scm_iprin1 (scm_unmemoize (obj), port, pstate);
SCM_SET_WRITINGP (pstate, writingp); SCM_SET_WRITINGP (pstate, writingp);
scm_gen_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
} }
@ -353,9 +353,9 @@ prindebugobj (obj, port, pstate)
SCM port; SCM port;
scm_print_state *pstate; scm_print_state *pstate;
{ {
scm_gen_puts (scm_regular_string, "#<debug-object ", port); scm_puts ("#<debug-object ", port);
scm_intprint (SCM_DEBUGOBJ_FRAME (obj), 16, port); scm_intprint (SCM_DEBUGOBJ_FRAME (obj), 16, port);
scm_gen_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
} }

6
libguile/dynl.c
View file

@ -321,11 +321,11 @@ print_dynl_obj (exp, port, pstate)
scm_print_state *pstate; scm_print_state *pstate;
{ {
struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (exp); struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (exp);
scm_gen_puts (scm_regular_string, "#<dynamic-object ", port); scm_puts ("#<dynamic-object ", port);
scm_iprin1 (d->filename, port, pstate); scm_iprin1 (d->filename, port, pstate);
if (d->handle == NULL) if (d->handle == NULL)
scm_gen_puts (scm_regular_string, " (unlinked)", port); scm_puts (" (unlinked)", port);
scm_gen_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
} }

4
libguile/eq.c
View file

@ -106,8 +106,8 @@ scm_equal_p (x, y)
y = SCM_CDR(y); y = SCM_CDR(y);
goto tailrecurse; goto tailrecurse;
} }
if (SCM_TYP7SD (x) == scm_tc7_string if (SCM_TYP7S (x) == scm_tc7_string
&& SCM_TYP7SD (y) == scm_tc7_string) && SCM_TYP7S (y) == scm_tc7_string)
return scm_string_equal_p (x, y); return scm_string_equal_p (x, y);
/* This ensures that types and scm_length are the same. */ /* This ensures that types and scm_length are the same. */
if (SCM_CAR(x) != SCM_CAR(y)) return SCM_BOOL_F; if (SCM_CAR(x) != SCM_CAR(y)) return SCM_BOOL_F;

6
libguile/eval.c
View file

@ -1938,9 +1938,7 @@ dispatch:
case scm_tc7_llvect: case scm_tc7_llvect:
#endif #endif
case scm_tc7_string: case scm_tc7_string:
case scm_tc7_mb_string:
case scm_tc7_substring: case scm_tc7_substring:
case scm_tc7_mb_substring:
case scm_tc7_smob: case scm_tc7_smob:
case scm_tcs_closures: case scm_tcs_closures:
case scm_tcs_subrs: case scm_tcs_subrs:
@ -3060,11 +3058,11 @@ prinprom (exp, port, pstate)
scm_print_state *pstate; scm_print_state *pstate;
{ {
int writingp = SCM_WRITINGP (pstate); int writingp = SCM_WRITINGP (pstate);
scm_gen_puts (scm_regular_string, "#<promise ", port); scm_puts ("#<promise ", port);
SCM_SET_WRITINGP (pstate, 1); SCM_SET_WRITINGP (pstate, 1);
scm_iprin1 (SCM_CDR (exp), port, pstate); scm_iprin1 (SCM_CDR (exp), port, pstate);
SCM_SET_WRITINGP (pstate, writingp); SCM_SET_WRITINGP (pstate, writingp);
scm_gen_putc ('>', port); scm_putc ('>', port);
return !0; return !0;
} }

0
libguile/extchrs.c
View file

0
libguile/extchrs.h
View file

6
libguile/fluids.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1996 Free Software Foundation, Inc. /* Copyright (C) 1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -105,9 +105,9 @@ print_fluid (exp, port, pstate)
SCM port; SCM port;
scm_print_state *pstate; scm_print_state *pstate;
{ {
scm_gen_puts (scm_regular_string, "#<fluid ", port); scm_puts ("#<fluid ", port);
scm_intprint (SCM_FLUID_NUM (exp), 10, port); scm_intprint (SCM_FLUID_NUM (exp), 10, port);
scm_gen_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
} }

13
libguile/gc.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996 Free Software Foundation, Inc. /* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -712,12 +712,10 @@ gc_mark_nimp:
#endif #endif
case scm_tc7_string: case scm_tc7_string:
case scm_tc7_mb_string:
SCM_SETGC8MARK (ptr); SCM_SETGC8MARK (ptr);
break; break;
case scm_tc7_substring: case scm_tc7_substring:
case scm_tc7_mb_substring:
if (SCM_GC8MARKP(ptr)) if (SCM_GC8MARKP(ptr))
break; break;
SCM_SETGC8MARK (ptr); SCM_SETGC8MARK (ptr);
@ -735,11 +733,8 @@ gc_mark_nimp:
sizeof (SCM *) * (scm_weak_size *= 2))); sizeof (SCM *) * (scm_weak_size *= 2)));
if (scm_weak_vectors == NULL) if (scm_weak_vectors == NULL)
{ {
scm_gen_puts (scm_regular_string, scm_puts ("weak vector table", scm_cur_errp);
"weak vector table", scm_puts ("\nFATAL ERROR DURING CRITICAL SCM_CODE SECTION\n",
scm_cur_errp);
scm_gen_puts (scm_regular_string,
"\nFATAL ERROR DURING CRITICAL SCM_CODE SECTION\n",
scm_cur_errp); scm_cur_errp);
exit(SCM_EXIT_FAILURE); exit(SCM_EXIT_FAILURE);
} }
@ -1173,12 +1168,10 @@ scm_gc_sweep ()
m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double); m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double);
goto freechars; goto freechars;
case scm_tc7_substring: case scm_tc7_substring:
case scm_tc7_mb_substring:
if (SCM_GC8MARKP (scmptr)) if (SCM_GC8MARKP (scmptr))
goto c8mrkcontinue; goto c8mrkcontinue;
break; break;
case scm_tc7_string: case scm_tc7_string:
case scm_tc7_mb_string:
if (SCM_GC8MARKP (scmptr)) if (SCM_GC8MARKP (scmptr))
goto c8mrkcontinue; goto c8mrkcontinue;
m += SCM_HUGE_LENGTH (scmptr) + 1; m += SCM_HUGE_LENGTH (scmptr) + 1;

2
libguile/gdbint.c
View file

@ -1,5 +1,5 @@
/* GDB interface for Guile /* GDB interface for Guile
* Copyright (C) 1996 Free Software Foundation * Copyright (C) 1996, 1997 Free Software Foundation
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by

399
libguile/genio.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996 Free Software Foundation, Inc. /* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -39,7 +39,6 @@
* whether to permit this exception to apply to your modifications. * 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. */
#include "extchrs.h"
#include <stdio.h> #include <stdio.h>
#include "_scm.h" #include "_scm.h"
#include "chars.h" #include "chars.h"
@ -51,11 +50,7 @@
#endif #endif
void
static void scm_putc SCM_P ((int c, SCM port));
static void
scm_putc (c, port) scm_putc (c, port)
int c; int c;
SCM port; SCM port;
@ -64,11 +59,7 @@ scm_putc (c, port)
SCM_SYSCALL ((scm_ptobs[i].fputc) (c, SCM_STREAM (port))); SCM_SYSCALL ((scm_ptobs[i].fputc) (c, SCM_STREAM (port)));
} }
void
static void scm_puts SCM_P ((char *s, SCM port));
static void
scm_puts (s, port) scm_puts (s, port)
char *s; char *s;
SCM port; SCM port;
@ -81,311 +72,24 @@ scm_puts (s, port)
#endif #endif
} }
void
scm_lfwrite (ptr, size, port)
static int scm_lfwrite SCM_P ((char *ptr, scm_sizet size, scm_sizet nitems, SCM port));
static int
scm_lfwrite (ptr, size, nitems, port)
char *ptr; char *ptr;
scm_sizet size; scm_sizet size;
scm_sizet nitems;
SCM port; SCM port;
{ {
int ret;
scm_sizet i = SCM_PTOBNUM (port); scm_sizet i = SCM_PTOBNUM (port);
SCM_SYSCALL (ret = (scm_ptobs[i].fwrite(ptr, size, nitems, SCM_STREAM (port)))); SCM_SYSCALL (scm_ptobs[i].fwrite(ptr, size, 1, SCM_STREAM (port)));
#ifdef TRANSCRIPT_SUPPORT #ifdef TRANSCRIPT_SUPPORT
if (scm_trans && (port == def_outp || port == cur_errp)) if (scm_trans && (port == def_outp || port == cur_errp))
SCM_SYSCALL (fwrite (ptr, size, nitems, scm_trans)); SCM_SYSCALL (fwrite (ptr, size, 1, scm_trans));
#endif #endif
return ret;
} }
int
void
scm_gen_putc (c, port)
int c;
SCM port;
{
switch (SCM_PORT_REPRESENTATION (port))
{
case scm_regular_port:
{
/* Nothing good to do with extended chars here...
* just truncate them.
*/
scm_putc ((unsigned char)c, port);
break;
}
case scm_mb_port:
{
char buf[256];
int len;
SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_MAKICHR (c),
"huge translation", "scm_gen_putc");
len = xwctomb (buf, c);
SCM_ASSERT ((len >= 0), SCM_MAKICHR (c), "bogus character", "scm_gen_putc");
if (len == 0)
scm_putc (0, port);
else
{
int x;
for (x = 0; x < len; ++x)
scm_putc (buf[x], port);
}
break;
}
case scm_wchar_port:
{
scm_putc (((unsigned char)(c >> 8) & 0xff), port);
scm_putc ((unsigned char)(c & 0xff), port);
break;
}
}
}
void
scm_gen_puts (rep, str_data, port)
enum scm_string_representation_type rep;
char *str_data;
SCM port;
{
switch (rep)
{
case scm_regular_string:
switch (SCM_PORT_REPRESENTATION (port))
{
case scm_regular_port:
case scm_mb_port:
scm_puts (str_data, port);
return;
case scm_wchar_port:
{
while (*str_data)
{
scm_putc (0, port);
scm_putc (*str_data, port);
++str_data;
}
return;
}
}
case scm_mb_string:
switch (SCM_PORT_REPRESENTATION (port))
{
case scm_regular_port:
case scm_mb_port:
scm_puts (str_data, port);
return;
case scm_wchar_port:
{
xwchar_t output;
int len;
int size;
size = strlen (str_data);
while (size)
{
len = xmbtowc (&output, str_data, size);
SCM_ASSERT ((len > 0), SCM_MAKINUM (*str_data),
"bogus character", "scm_gen_puts");
scm_putc ((output >> 8) & 0xff, port);
scm_putc (output & 0xff, port);
size -= len;
str_data += len;
}
return;
}
}
case scm_wchar_string:
{
xwchar_t * wstr_data;
wstr_data = (xwchar_t *) str_data;
switch (SCM_PORT_REPRESENTATION (port))
{
case scm_regular_port:
while (*wstr_data)
{
scm_putc ((unsigned char) *wstr_data, port);
++wstr_data;
}
return;
case scm_mb_port:
{
char buf[256];
SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F,
"huge translation", "scm_gen_puts");
while (*wstr_data)
{
int len;
len = xwctomb (buf, *wstr_data);
SCM_ASSERT ((len > 0), SCM_MAKINUM (*wstr_data), "bogus character", "scm_gen_puts");
{
int x;
for (x = 0; x < len; ++x)
scm_putc (buf[x], port);
}
++wstr_data;
}
return;
}
case scm_wchar_port:
{
int len;
for (len = 0; wstr_data[len]; ++len)
;
scm_lfwrite (str_data, sizeof (xwchar_t), len, port);
return;
}
}
}
}
}
void
scm_gen_write (rep, str_data, nitems, port)
enum scm_string_representation_type rep;
char *str_data;
scm_sizet nitems;
SCM port;
{
/* is nitems bytes or characters in the mb_string case? */
switch (rep)
{
case scm_regular_string:
switch (SCM_PORT_REPRESENTATION (port))
{
case scm_regular_port:
case scm_mb_port:
scm_lfwrite (str_data, 1, nitems, port);
return;
case scm_wchar_port:
{
while (nitems)
{
scm_putc (0, port);
scm_putc (*str_data, port);
++str_data;
--nitems;
}
return;
}
}
case scm_mb_string:
switch (SCM_PORT_REPRESENTATION (port))
{
case scm_regular_port:
case scm_mb_port:
scm_lfwrite (str_data, 1, nitems, port);
return;
case scm_wchar_port:
{
xwchar_t output;
int len;
while (nitems)
{
len = xmbtowc (&output, str_data, nitems);
SCM_ASSERT ((len > 0), SCM_MAKINUM (*str_data), "bogus character", "scm_gen_puts");
scm_putc ((output >> 8) & 0xff, port);
scm_putc (output & 0xff, port);
nitems -= len;
str_data += len;
}
return;
}
}
case scm_wchar_string:
{
xwchar_t * wstr_data;
wstr_data = (xwchar_t *) str_data;
switch (SCM_PORT_REPRESENTATION (port))
{
case scm_regular_port:
while (nitems)
{
scm_putc ((unsigned char) *wstr_data, port);
++wstr_data;
--nitems;
}
return;
case scm_mb_port:
{
char buf[256];
SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F,
"huge translation", "scm_gen_puts");
while (nitems)
{
int len;
len = xwctomb (buf, *wstr_data);
SCM_ASSERT ((len > 0), SCM_MAKINUM (*wstr_data), "bogus character", "scm_gen_puts");
{
int x;
for (x = 0; x < len; ++x)
scm_putc (buf[x], port);
}
++wstr_data;
--nitems;
}
return;
}
case scm_wchar_port:
{
scm_lfwrite (str_data, sizeof (xwchar_t), nitems, port);
return;
}
}
}
}
}
static int scm_getc SCM_P ((SCM port));
static int
scm_getc (port) scm_getc (port)
SCM port; SCM port;
{ {
@ -393,26 +97,19 @@ scm_getc (port)
int c; int c;
scm_sizet i; scm_sizet i;
f = SCM_STREAM (port);
i = SCM_PTOBNUM (port);
SCM_SYSCALL (c = (scm_ptobs[i].fgetc) (f));
return c;
}
int
scm_gen_getc (port)
SCM port;
{
int c;
/* One char may be stored in the high bits of (car port) orre@nada.kth.se. */ /* One char may be stored in the high bits of (car port) orre@nada.kth.se. */
if (SCM_CRDYP (port)) if (SCM_CRDYP (port))
{ {
c = SCM_CGETUN (port); c = SCM_CGETUN (port);
SCM_CLRDY (port); /* Clear ungetted char */ SCM_CLRDY (port); /* Clear ungetted char */
}
else
{
f = SCM_STREAM (port);
i = SCM_PTOBNUM (port);
SCM_SYSCALL (c = (scm_ptobs[i].fgetc) (f));
}
return_c:
if (c == '\n') if (c == '\n')
{ {
SCM_INCLINE (port); SCM_INCLINE (port);
@ -425,75 +122,17 @@ scm_gen_getc (port)
{ {
SCM_INCCOL (port); SCM_INCCOL (port);
} }
return c; return c;
} }
switch (SCM_PORT_REPRESENTATION (port))
{
case scm_regular_port:
c = scm_getc (port);
goto return_c;
case scm_mb_port:
{
int x;
char buf[256];
SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F,
"huge translation", "scm_gen_puts");
x = 0;
while (1)
{
xwchar_t out;
c = scm_getc (port);
if (c == EOF)
return EOF;
buf[x] = c;
if (xmbtowc (&out, buf, x + 1) > 0)
{
c = out;
goto return_c;
}
SCM_ASSERT (x < sizeof (buf), SCM_BOOL_F,
"huge translation", "scm_gen_getc");
++x;
}
}
case scm_wchar_port:
{
int hi;
int lo;
hi = scm_getc (port);
lo = (hi == EOF
? EOF
: scm_getc (port));
c = ((hi == EOF)
? EOF
: ((hi << 8) | lo));
goto return_c;
}
default:
return EOF;
}
}
void void
scm_gen_ungetc (c, port) scm_ungetc (c, port)
int c; int c;
SCM port; SCM port;
{ {
/* SCM_ASSERT(!SCM_CRDYP(port), port, SCM_ARG2, "too many scm_gen_ungetc");*/ /* SCM_ASSERT(!SCM_CRDYP(port), port, SCM_ARG2, "too many scm_ungetc");*/
SCM_CUNGET (c, port); SCM_CUNGET (c, port);
if (c == '\n') if (c == '\n')
{ {
@ -508,7 +147,7 @@ scm_gen_ungetc (c, port)
char * char *
scm_gen_read_line (port) scm_do_read_line (port)
SCM port; SCM port;
{ {
char *s; char *s;

17
libguile/genio.h
View file

@ -2,7 +2,7 @@
#ifndef GENIOH #ifndef GENIOH
#define GENIOH #define GENIOH
/* Copyright (C) 1995,1996 Free Software Foundation, Inc. /* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -48,13 +48,12 @@
extern void scm_gen_putc SCM_P ((int c, SCM port)); extern void scm_putc SCM_P ((int c, SCM port));
extern void scm_gen_puts SCM_P ((enum scm_string_representation_type rep, extern void scm_puts SCM_P ((char *str_data, SCM port));
char *str_data, extern void scm_lfwrite SCM_P ((char *ptr, scm_sizet size, SCM port));
SCM port)); extern int scm_getc SCM_P ((SCM port));
extern void scm_gen_write SCM_P ((enum scm_string_representation_type rep, char *str_data, scm_sizet nitems, SCM port)); extern void scm_ungetc SCM_P ((int c, SCM port));
extern int scm_gen_getc SCM_P ((SCM port)); /* FIXME: this is a terrible name. */
extern void scm_gen_ungetc SCM_P ((int c, SCM port)); extern char *scm_do_read_line SCM_P ((SCM port));
extern char *scm_gen_read_line SCM_P ((SCM port));
#endif /* GENIOH */ #endif /* GENIOH */

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"
}

10
libguile/gsubr.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996 Free Software Foundation, Inc. /* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -172,13 +172,13 @@ SCM
gsubr_21l(req1, req2, opt, rst) gsubr_21l(req1, req2, opt, rst)
SCM req1, req2, opt, rst; SCM req1, req2, opt, rst;
{ {
scm_gen_puts (scm_regular_string, "gsubr-2-1-l:\n req1: ", scm_cur_outp); scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
scm_display(req1, scm_cur_outp); scm_display(req1, scm_cur_outp);
scm_gen_puts (scm_regular_string, "\n req2: ", scm_cur_outp); scm_puts ("\n req2: ", scm_cur_outp);
scm_display(req2, scm_cur_outp); scm_display(req2, scm_cur_outp);
scm_gen_puts (scm_regular_string, "\n opt: ", scm_cur_outp); scm_puts ("\n opt: ", scm_cur_outp);
scm_display(opt, scm_cur_outp); scm_display(opt, scm_cur_outp);
scm_gen_puts (scm_regular_string, "\n rest: ", scm_cur_outp); scm_puts ("\n rest: ", scm_cur_outp);
scm_display(rst, scm_cur_outp); scm_display(rst, scm_cur_outp);
scm_newline(scm_cur_outp); scm_newline(scm_cur_outp);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;

4
libguile/hash.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996 Free Software Foundation, Inc. /* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -98,9 +98,7 @@ scm_hasher(obj, n, d)
} }
case scm_tcs_symbols: case scm_tcs_symbols:
case scm_tc7_string: case scm_tc7_string:
case scm_tc7_mb_string:
case scm_tc7_substring: case scm_tc7_substring:
case scm_tc7_mb_substring:
return scm_strhash(SCM_ROUCHARS(obj), (scm_sizet) SCM_ROLENGTH(obj), n); return scm_strhash(SCM_ROUCHARS(obj), (scm_sizet) SCM_ROLENGTH(obj), n);
case scm_tc7_wvect: case scm_tc7_wvect:
case scm_tc7_vector: case scm_tc7_vector:

2
libguile/init.c
View file

@ -73,7 +73,6 @@
#include "list.h" #include "list.h"
#include "load.h" #include "load.h"
#include "mallocs.h" #include "mallocs.h"
#include "mbstrings.h"
#include "net_db.h" #include "net_db.h"
#include "numbers.h" #include "numbers.h"
#include "objects.h" #include "objects.h"
@ -443,7 +442,6 @@ scm_boot_guile_1 (base, closure)
scm_init_stime (); scm_init_stime ();
scm_init_strings (); scm_init_strings ();
scm_init_strorder (); scm_init_strorder ();
scm_init_mbstrings ();
scm_init_strop (); scm_init_strop ();
scm_init_throw (); scm_init_throw ();
scm_init_variable (); scm_init_variable ();

6
libguile/ioext.c
View file

@ -117,13 +117,13 @@ scm_read_delimited_x (delims, buf, gobble, port, start, end)
{ {
int k; int k;
c = scm_gen_getc (port); c = scm_getc (port);
for (k = 0; k < num_delims; k++) for (k = 0; k < num_delims; k++)
{ {
if (cdelims[k] == c) if (cdelims[k] == c)
{ {
if (SCM_FALSEP (gobble)) if (SCM_FALSEP (gobble))
scm_gen_ungetc (c, port); scm_ungetc (c, port);
return scm_cons (SCM_MAKICHR (c), return scm_cons (SCM_MAKICHR (c),
scm_long2num (j - cstart)); scm_long2num (j - cstart));
@ -154,7 +154,7 @@ scm_read_line (port)
port, SCM_ARG1, s_read_line); port, SCM_ARG1, s_read_line);
} }
s = scm_gen_read_line (port); s = scm_do_read_line (port);
return (s == NULL ? SCM_EOF_VAL : scm_makfrom0str (s)); return (s == NULL ? SCM_EOF_VAL : scm_makfrom0str (s));
} }

11
libguile/kw.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996 Free Software Foundation, Inc. /* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -43,7 +43,6 @@
#include <stdio.h> #include <stdio.h>
#include "_scm.h" #include "_scm.h"
#include "genio.h" #include "genio.h"
#include "mbstrings.h"
#include "smob.h" #include "smob.h"
#include "kw.h" #include "kw.h"
@ -68,12 +67,8 @@ prin_kw (exp, port, pstate)
SCM port; SCM port;
scm_print_state *pstate; scm_print_state *pstate;
{ {
scm_gen_puts (scm_regular_string, "#:", port); scm_puts ("#:", port);
scm_gen_puts((SCM_MB_STRINGP(SCM_CDR (exp)) scm_puts(1 + SCM_CHARS (SCM_CDR (exp)), port);
? scm_mb_string
: scm_regular_string),
1 + SCM_CHARS (SCM_CDR (exp)),
port);
return 1; return 1;
} }

4
libguile/libguile.h
View file

@ -1,7 +1,7 @@
#ifndef LIBGUILEH #ifndef LIBGUILEH
#define LIBGUILEH #define LIBGUILEH
/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. /* Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -68,7 +68,6 @@
#include "libguile/eq.h" #include "libguile/eq.h"
#include "libguile/error.h" #include "libguile/error.h"
#include "libguile/eval.h" #include "libguile/eval.h"
#include "libguile/extchrs.h"
#include "libguile/feature.h" #include "libguile/feature.h"
#include "libguile/filesys.h" #include "libguile/filesys.h"
#include "libguile/fports.h" #include "libguile/fports.h"
@ -85,7 +84,6 @@
#include "libguile/load.h" #include "libguile/load.h"
#include "libguile/mallocs.h" #include "libguile/mallocs.h"
#include "libguile/markers.h" #include "libguile/markers.h"
#include "libguile/mbstrings.h"
#include "libguile/net_db.h" #include "libguile/net_db.h"
#include "libguile/numbers.h" #include "libguile/numbers.h"
#include "libguile/objprop.h" #include "libguile/objprop.h"

6
libguile/mallocs.c
View file

@ -1,6 +1,6 @@
/* classes: src_files */ /* classes: src_files */
/* Copyright (C) 1995 Free Software Foundation, Inc. /* Copyright (C) 1995, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -58,9 +58,9 @@ prinmalloc (exp, port, pstate)
SCM port; SCM port;
scm_print_state *pstate; scm_print_state *pstate;
{ {
scm_gen_puts(scm_regular_string, "#<malloc ", port); scm_puts("#<malloc ", port);
scm_intprint(SCM_CDR(exp), 16, port); scm_intprint(SCM_CDR(exp), 16, port);
scm_gen_putc('>', port); scm_putc('>', port);
return 1; return 1;
} }

0
libguile/mbstrings.c
View file

0
libguile/mbstrings.h
View file

6
libguile/numbers.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996 Free Software Foundation, Inc. /* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -1441,7 +1441,7 @@ scm_floprint(sexp, port, pstate)
{ {
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
char num_buf[SCM_FLOBUFLEN]; char num_buf[SCM_FLOBUFLEN];
scm_gen_write (scm_regular_string, num_buf, iflo2str(sexp, num_buf), port); scm_lfwrite (num_buf, iflo2str(sexp, num_buf), port);
#else #else
scm_ipruk("float", sexp, port); scm_ipruk("float", sexp, port);
#endif #endif
@ -1458,7 +1458,7 @@ scm_bigprint(exp, port, pstate)
{ {
#ifdef SCM_BIGDIG #ifdef SCM_BIGDIG
exp = big2str(exp, (unsigned int)10); exp = big2str(exp, (unsigned int)10);
scm_gen_write (scm_regular_string, SCM_CHARS(exp), (scm_sizet)SCM_LENGTH(exp), port); scm_lfwrite (SCM_CHARS(exp), (scm_sizet)SCM_LENGTH(exp), port);
#else #else
scm_ipruk("bignum", exp, port); scm_ipruk("bignum", exp, port);
#endif #endif

25
libguile/ports.c
View file

@ -258,7 +258,6 @@ scm_add_to_port_table (port)
scm_port_table[scm_port_table_size]->file_name = SCM_BOOL_F; scm_port_table[scm_port_table_size]->file_name = SCM_BOOL_F;
scm_port_table[scm_port_table_size]->line_number = 1; scm_port_table[scm_port_table_size]->line_number = 1;
scm_port_table[scm_port_table_size]->column_number = 0; scm_port_table[scm_port_table_size]->column_number = 0;
scm_port_table[scm_port_table_size]->representation = scm_regular_port;
return scm_port_table[scm_port_table_size++]; return scm_port_table[scm_port_table_size++];
} }
@ -543,7 +542,7 @@ scm_read_char (port)
port = scm_cur_inp; port = scm_cur_inp;
else else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char); SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char);
c = scm_gen_getc (port); c = scm_getc (port);
if (EOF == c) if (EOF == c)
return SCM_EOF_VAL; return SCM_EOF_VAL;
return SCM_MAKICHR (c); return SCM_MAKICHR (c);
@ -561,10 +560,10 @@ scm_peek_char (port)
port = scm_cur_inp; port = scm_cur_inp;
else else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char); SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char);
c = scm_gen_getc (port); c = scm_getc (port);
if (EOF == c) if (EOF == c)
return SCM_EOF_VAL; return SCM_EOF_VAL;
scm_gen_ungetc (c, port); scm_ungetc (c, port);
return SCM_MAKICHR (c); return SCM_MAKICHR (c);
} }
@ -642,7 +641,7 @@ scm_unread_char (cobj, port)
c = SCM_ICHR (cobj); c = SCM_ICHR (cobj);
scm_gen_ungetc (c, port); scm_ungetc (c, port);
return cobj; return cobj;
} }
@ -765,25 +764,25 @@ scm_prinport (exp, port, type)
SCM port; SCM port;
char *type; char *type;
{ {
scm_gen_puts (scm_regular_string, "#<", port); scm_puts ("#<", port);
if (SCM_CLOSEDP (exp)) if (SCM_CLOSEDP (exp))
scm_gen_puts (scm_regular_string, "closed: ", port); scm_puts ("closed: ", port);
else else
{ {
if (SCM_RDNG & SCM_CAR (exp)) if (SCM_RDNG & SCM_CAR (exp))
scm_gen_puts (scm_regular_string, "input: ", port); scm_puts ("input: ", port);
if (SCM_WRTNG & SCM_CAR (exp)) if (SCM_WRTNG & SCM_CAR (exp))
scm_gen_puts (scm_regular_string, "output: ", port); scm_puts ("output: ", port);
} }
scm_gen_puts (scm_regular_string, type, port); scm_puts (type, port);
scm_gen_putc (' ', port); scm_putc (' ', port);
#ifndef MSDOS #ifndef MSDOS
#ifndef __EMX__ #ifndef __EMX__
#ifndef _DCC #ifndef _DCC
#ifndef AMIGA #ifndef AMIGA
#ifndef THINK_C #ifndef THINK_C
if (SCM_OPENP (exp) && scm_tc16_fport == SCM_TYP16 (exp) && isatty (fileno ((FILE *)SCM_STREAM (exp)))) if (SCM_OPENP (exp) && scm_tc16_fport == SCM_TYP16 (exp) && isatty (fileno ((FILE *)SCM_STREAM (exp))))
scm_gen_puts (scm_regular_string, ttyname (fileno ((FILE *)SCM_STREAM (exp))), port); scm_puts (ttyname (fileno ((FILE *)SCM_STREAM (exp))), port);
else else
#endif #endif
#endif #endif
@ -794,7 +793,7 @@ scm_prinport (exp, port, type)
scm_intprint ((long) fileno ((FILE *)SCM_STREAM (exp)), 10, port); scm_intprint ((long) fileno ((FILE *)SCM_STREAM (exp)), 10, port);
else else
scm_intprint (SCM_CDR (exp), 16, port); scm_intprint (SCM_CDR (exp), 16, port);
scm_gen_putc ('>', port); scm_putc ('>', port);
} }

19
libguile/ports.h
View file

@ -50,21 +50,6 @@
enum scm_port_representation_type
{
scm_regular_port,
scm_mb_port,
scm_wchar_port
};
enum scm_string_representation_type
{
scm_regular_string = scm_regular_port,
scm_mb_string = scm_mb_port,
scm_wchar_string = scm_wchar_port
};
struct scm_port_table struct scm_port_table
{ {
SCM port; /* Open port. */ SCM port; /* Open port. */
@ -78,8 +63,6 @@ struct scm_port_table
int line_number; /* debugging support. */ int line_number; /* debugging support. */
int column_number; /* debugging support. */ int column_number; /* debugging support. */
enum scm_port_representation_type representation;
}; };
extern struct scm_port_table **scm_port_table; extern struct scm_port_table **scm_port_table;
@ -124,8 +107,6 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */
#define SCM_COL(x) SCM_PTAB_ENTRY(x)->column_number #define SCM_COL(x) SCM_PTAB_ENTRY(x)->column_number
#define SCM_REVEALED(x) SCM_PTAB_ENTRY(x)->revealed #define SCM_REVEALED(x) SCM_PTAB_ENTRY(x)->revealed
#define SCM_SETREVEALED(x,s) (SCM_PTAB_ENTRY(x)->revealed = s) #define SCM_SETREVEALED(x,s) (SCM_PTAB_ENTRY(x)->revealed = s)
#define SCM_PORT_REPRESENTATION(x) SCM_PTAB_ENTRY(x)->representation
#define SCM_SET_PORT_REPRESENTATION(x,s) (SCM_PTAB_ENTRY(x)->representation = s)
#define SCM_CRDYP(port) (SCM_CAR (port) & SCM_CRDY) #define SCM_CRDYP(port) (SCM_CAR (port) & SCM_CRDY)
#define SCM_CLRDY(port) {SCM_SETAND_CAR (port, SCM_CUC);} #define SCM_CLRDY(port) {SCM_SETAND_CAR (port, SCM_CUC);}
#define SCM_SETRDY(port) {SCM_SETOR_CAR (port, SCM_CRDY);} #define SCM_SETRDY(port) {SCM_SETOR_CAR (port, SCM_CRDY);}

157
libguile/print.c
View file

@ -44,7 +44,6 @@
#include "_scm.h" #include "_scm.h"
#include "chars.h" #include "chars.h"
#include "genio.h" #include "genio.h"
#include "mbstrings.h"
#include "smob.h" #include "smob.h"
#include "eval.h" #include "eval.h"
#include "procprop.h" #include "procprop.h"
@ -146,7 +145,7 @@ scm_print_options (setting)
{ \ { \
if (pstate->top - pstate->list_offset >= pstate->level) \ if (pstate->top - pstate->list_offset >= pstate->level) \
{ \ { \
scm_gen_putc ('#', port); \ scm_putc ('#', port); \
return; \ return; \
} \ } \
} \ } \
@ -222,9 +221,9 @@ print_state_printer (obj, port)
SCM_ARG2, SCM_ARG2,
s_print_state_printer); s_print_state_printer);
port = SCM_COERCE_OPORT (port); port = SCM_COERCE_OPORT (port);
scm_gen_puts (scm_regular_string, "#<print-state ", port); scm_puts ("#<print-state ", port);
scm_intprint (obj, 16, port); scm_intprint (obj, 16, port);
scm_gen_putc ('>', port); scm_putc ('>', port);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
@ -287,9 +286,9 @@ print_circref (port, pstate, ref)
for (i = pstate->top - 1; 1; --i) for (i = pstate->top - 1; 1; --i)
if (pstate->ref_stack[i] == ref) if (pstate->ref_stack[i] == ref)
break; break;
scm_gen_putc ('#', port); scm_putc ('#', port);
scm_intprint (i - self, 10, port); scm_intprint (i - self, 10, port);
scm_gen_putc ('#', port); scm_putc ('#', port);
} }
/* Print generally. Handles both write and display according to PSTATE. /* Print generally. Handles both write and display according to PSTATE.
@ -314,17 +313,27 @@ taloop:
if (SCM_ICHRP (exp)) if (SCM_ICHRP (exp))
{ {
i = SCM_ICHR (exp); i = SCM_ICHR (exp);
scm_put_wchar (i, port, SCM_WRITINGP (pstate)); if (SCM_WRITINGP (pstate))
{
scm_puts ("#\\", port);
if ((i >= 0) && (i <= ' ') && scm_charnames[i])
scm_puts (scm_charnames[i], port);
else if (i < 0 || i > '\177')
scm_intprint (i, 8, port);
else
scm_putc (i, port);
}
else
scm_putc (i, port);
} }
else if (SCM_IFLAGP (exp) else if (SCM_IFLAGP (exp)
&& (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *)))) && (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *))))
scm_gen_puts (scm_regular_string, SCM_ISYMCHARS (exp), port); scm_puts (SCM_ISYMCHARS (exp), port);
else if (SCM_ILOCP (exp)) else if (SCM_ILOCP (exp))
{ {
scm_gen_puts (scm_regular_string, "#@", port); scm_puts ("#@", port);
scm_intprint ((long) SCM_IFRAME (exp), 10, port); scm_intprint ((long) SCM_IFRAME (exp), 10, port);
scm_gen_putc (SCM_ICDRP (exp) ? '-' : '+', port); scm_putc (SCM_ICDRP (exp) ? '-' : '+', port);
scm_intprint ((long) SCM_IDIST (exp), 10, port); scm_intprint ((long) SCM_IDIST (exp), 10, port);
} }
else else
@ -332,7 +341,7 @@ taloop:
break; break;
case 1: case 1:
/* gloc */ /* gloc */
scm_gen_puts (scm_regular_string, "#@", port); scm_puts ("#@", port);
exp = SCM_CAR (exp - 1); exp = SCM_CAR (exp - 1);
goto taloop; goto taloop;
default: default:
@ -380,21 +389,20 @@ taloop:
if (!SCM_CLOSUREP (SCM_CDR (exp))) if (!SCM_CLOSUREP (SCM_CDR (exp)))
{ {
code = env = 0; code = env = 0;
scm_gen_puts (scm_regular_string, "#<primitive-", scm_puts ("#<primitive-", port);
port);
} }
else else
{ {
code = SCM_CODE (SCM_CDR (exp)); code = SCM_CODE (SCM_CDR (exp));
env = SCM_ENV (SCM_CDR (exp)); env = SCM_ENV (SCM_CDR (exp));
scm_gen_puts (scm_regular_string, "#<", port); scm_puts ("#<", port);
} }
if (SCM_CAR (exp) & (3L << 16)) if (SCM_CAR (exp) & (3L << 16))
scm_gen_puts (scm_regular_string, "macro", port); scm_puts ("macro", port);
else else
scm_gen_puts (scm_regular_string, "syntax", port); scm_puts ("syntax", port);
if (SCM_CAR (exp) & (2L << 16)) if (SCM_CAR (exp) & (2L << 16))
scm_gen_putc ('!', port); scm_putc ('!', port);
} }
else else
{ {
@ -402,13 +410,12 @@ taloop:
name = scm_procedure_name (exp); name = scm_procedure_name (exp);
code = SCM_CODE (exp); code = SCM_CODE (exp);
env = SCM_ENV (exp); env = SCM_ENV (exp);
scm_gen_puts (scm_regular_string, "#<procedure", scm_puts ("#<procedure", port);
port);
} }
if (SCM_NIMP (name) && SCM_ROSTRINGP (name)) if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
{ {
scm_gen_putc (' ', port); scm_putc (' ', port);
scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port); scm_puts (SCM_ROCHARS (name), port);
} }
if (code) if (code)
{ {
@ -426,49 +433,38 @@ taloop:
{ {
if (SCM_TYP16 (exp) != scm_tc16_macro) if (SCM_TYP16 (exp) != scm_tc16_macro)
{ {
scm_gen_putc (' ', port); scm_putc (' ', port);
scm_iprin1 (SCM_CAR (code), port, pstate); scm_iprin1 (SCM_CAR (code), port, pstate);
} }
scm_gen_putc ('>', port); scm_putc ('>', port);
} }
} }
else else
scm_gen_putc ('>', port); scm_putc ('>', port);
} }
break; break;
case scm_tc7_mb_string:
case scm_tc7_mb_substring:
scm_print_mb_string (exp, port, SCM_WRITINGP (pstate));
break;
case scm_tc7_substring: case scm_tc7_substring:
case scm_tc7_string: case scm_tc7_string:
if (SCM_WRITINGP (pstate)) if (SCM_WRITINGP (pstate))
{ {
scm_gen_putc ('"', port); scm_putc ('"', port);
for (i = 0; i < SCM_ROLENGTH (exp); ++i) for (i = 0; i < SCM_ROLENGTH (exp); ++i)
switch (SCM_ROCHARS (exp)[i]) switch (SCM_ROCHARS (exp)[i])
{ {
case '"': case '"':
case '\\': case '\\':
scm_gen_putc ('\\', port); scm_putc ('\\', port);
default: default:
scm_gen_putc (SCM_ROCHARS (exp)[i], port); scm_putc (SCM_ROCHARS (exp)[i], port);
} }
scm_gen_putc ('"', port); scm_putc ('"', port);
break; break;
} }
else else
scm_gen_write (scm_regular_string, SCM_ROCHARS (exp), scm_lfwrite (SCM_ROCHARS (exp), (scm_sizet) SCM_ROLENGTH (exp),
(scm_sizet) SCM_ROLENGTH (exp),
port); port);
break; break;
case scm_tcs_symbols: case scm_tcs_symbols:
if (SCM_MB_STRINGP (exp))
{
scm_print_mb_symbol (exp, port);
break;
}
else
{ {
int pos; int pos;
int end; int end;
@ -486,7 +482,7 @@ taloop:
maybe_weird = 0; maybe_weird = 0;
if (len == 0) if (len == 0)
scm_gen_write (scm_regular_string, "#{}#", 4, port); scm_lfwrite ("#{}#", 4, port);
for (end = pos; end < len; ++end) for (end = pos; end < len; ++end)
switch (str[end]) switch (str[end])
@ -509,18 +505,18 @@ taloop:
} }
if (!weird) if (!weird)
{ {
scm_gen_write (scm_regular_string, "#{", 2, port); scm_lfwrite ("#{", 2, port);
weird = 1; weird = 1;
} }
if (pos < end) if (pos < end)
{ {
scm_gen_write (scm_regular_string, str + pos, end - pos, port); scm_lfwrite (str + pos, end - pos, port);
} }
{ {
char buf[2]; char buf[2];
buf[0] = '\\'; buf[0] = '\\';
buf[1] = str[end]; buf[1] = str[end];
scm_gen_write (scm_regular_string, buf, 2, port); scm_lfwrite (buf, 2, port);
} }
pos = end + 1; pos = end + 1;
break; break;
@ -542,22 +538,22 @@ taloop:
break; break;
} }
if (pos < end) if (pos < end)
scm_gen_write (scm_regular_string, str + pos, end - pos, port); scm_lfwrite (str + pos, end - pos, port);
if (weird) if (weird)
scm_gen_write (scm_regular_string, "}#", 2, port); scm_lfwrite ("}#", 2, port);
break; break;
} }
case scm_tc7_wvect: case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref); ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_IS_WHVEC (exp)) if (SCM_IS_WHVEC (exp))
scm_gen_puts (scm_regular_string, "#wh(", port); scm_puts ("#wh(", port);
else else
scm_gen_puts (scm_regular_string, "#w(", port); scm_puts ("#w(", port);
goto common_vector_printer; goto common_vector_printer;
case scm_tc7_vector: case scm_tc7_vector:
ENTER_NESTED_DATA (pstate, exp, circref); ENTER_NESTED_DATA (pstate, exp, circref);
scm_gen_puts (scm_regular_string, "#(", port); scm_puts ("#(", port);
common_vector_printer: common_vector_printer:
{ {
int last = SCM_LENGTH (exp) - 1; int last = SCM_LENGTH (exp) - 1;
@ -571,7 +567,7 @@ taloop:
{ {
/* CHECK_INTS; */ /* CHECK_INTS; */
scm_iprin1 (SCM_VELTS (exp)[i], port, pstate); scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
scm_gen_putc (' ', port); scm_putc (' ', port);
} }
if (i == last) if (i == last)
{ {
@ -579,8 +575,8 @@ taloop:
scm_iprin1 (SCM_VELTS (exp)[i], port, pstate); scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
} }
if (cutp) if (cutp)
scm_gen_puts (scm_regular_string, " ...", port); scm_puts (" ...", port);
scm_gen_putc (')', port); scm_putc (')', port);
} }
EXIT_NESTED_DATA (pstate); EXIT_NESTED_DATA (pstate);
break; break;
@ -598,26 +594,23 @@ taloop:
scm_raprin1 (exp, port, pstate); scm_raprin1 (exp, port, pstate);
break; break;
case scm_tcs_subrs: case scm_tcs_subrs:
scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port); scm_puts ("#<primitive-procedure ", port);
scm_gen_puts ((SCM_MB_STRINGP (SCM_SNAME(exp)) scm_puts (SCM_CHARS (SCM_SNAME (exp)), port);
? scm_mb_string scm_putc ('>', port);
: scm_regular_string),
SCM_CHARS (SCM_SNAME (exp)), port);
scm_gen_putc ('>', port);
break; break;
#ifdef CCLO #ifdef CCLO
case scm_tc7_cclo: case scm_tc7_cclo:
scm_gen_puts (scm_regular_string, "#<compiled-closure ", port); scm_puts ("#<compiled-closure ", port);
scm_iprin1 (SCM_CCLO_SUBR (exp), port, pstate); scm_iprin1 (SCM_CCLO_SUBR (exp), port, pstate);
scm_gen_putc ('>', port); scm_putc ('>', port);
break; break;
#endif #endif
case scm_tc7_contin: case scm_tc7_contin:
scm_gen_puts (scm_regular_string, "#<continuation ", port); scm_puts ("#<continuation ", port);
scm_intprint (SCM_LENGTH (exp), 10, port); scm_intprint (SCM_LENGTH (exp), 10, port);
scm_gen_puts (scm_regular_string, " @ ", port); scm_puts (" @ ", port);
scm_intprint ((long) SCM_CHARS (exp), 16, port); scm_intprint ((long) SCM_CHARS (exp), 16, port);
scm_gen_putc ('>', port); scm_putc ('>', port);
break; break;
case scm_tc7_port: case scm_tc7_port:
i = SCM_PTOBNUM (exp); i = SCM_PTOBNUM (exp);
@ -718,7 +711,7 @@ scm_intprint (n, radix, port)
SCM port; SCM port;
{ {
char num_buf[SCM_INTBUFLEN]; char num_buf[SCM_INTBUFLEN];
scm_gen_write (scm_regular_string, num_buf, scm_iint2str (n, radix, num_buf), port); scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port);
} }
/* Print an object of unrecognized type. /* Print an object of unrecognized type.
@ -730,19 +723,19 @@ scm_ipruk (hdr, ptr, port)
SCM ptr; SCM ptr;
SCM port; SCM port;
{ {
scm_gen_puts (scm_regular_string, "#<unknown-", port); scm_puts ("#<unknown-", port);
scm_gen_puts (scm_regular_string, hdr, port); scm_puts (hdr, port);
if (SCM_CELLP (ptr)) if (SCM_CELLP (ptr))
{ {
scm_gen_puts (scm_regular_string, " (0x", port); scm_puts (" (0x", port);
scm_intprint (SCM_CAR (ptr), 16, port); scm_intprint (SCM_CAR (ptr), 16, port);
scm_gen_puts (scm_regular_string, " . 0x", port); scm_puts (" . 0x", port);
scm_intprint (SCM_CDR (ptr), 16, port); scm_intprint (SCM_CDR (ptr), 16, port);
scm_gen_puts (scm_regular_string, ") @", port); scm_puts (") @", port);
} }
scm_gen_puts (scm_regular_string, " 0x", port); scm_puts (" 0x", port);
scm_intprint (ptr, 16, port); scm_intprint (ptr, 16, port);
scm_gen_putc ('>', port); scm_putc ('>', port);
} }
/* Print a list. /* Print a list.
@ -760,7 +753,7 @@ scm_iprlist (hdr, exp, tlr, port, pstate)
register int i; register int i;
register SCM hare, tortoise; register SCM hare, tortoise;
int floor = pstate->top - 2; int floor = pstate->top - 2;
scm_gen_puts (scm_regular_string, hdr, port); scm_puts (hdr, port);
/* CHECK_INTS; */ /* CHECK_INTS; */
if (pstate->fancyp) if (pstate->fancyp)
goto fancy_printing; goto fancy_printing;
@ -791,18 +784,18 @@ scm_iprlist (hdr, exp, tlr, port, pstate)
if (pstate->ref_stack[i] == exp) if (pstate->ref_stack[i] == exp)
goto circref; goto circref;
PUSH_REF (pstate, exp); PUSH_REF (pstate, exp);
scm_gen_putc (' ', port); scm_putc (' ', port);
/* CHECK_INTS; */ /* CHECK_INTS; */
scm_iprin1 (SCM_CAR (exp), port, pstate); scm_iprin1 (SCM_CAR (exp), port, pstate);
} }
if (SCM_NNULLP (exp)) if (SCM_NNULLP (exp))
{ {
scm_gen_puts (scm_regular_string, " . ", port); scm_puts (" . ", port);
scm_iprin1 (exp, port, pstate); scm_iprin1 (exp, port, pstate);
} }
end: end:
scm_gen_putc (tlr, port); scm_putc (tlr, port);
pstate->top = floor + 2; pstate->top = floor + 2;
return; return;
@ -823,7 +816,7 @@ fancy_printing:
{ {
if (n == 0) if (n == 0)
{ {
scm_gen_puts (scm_regular_string, " ...", port); scm_puts (" ...", port);
goto skip_tail; goto skip_tail;
} }
else else
@ -831,14 +824,14 @@ fancy_printing:
} }
PUSH_REF(pstate, exp); PUSH_REF(pstate, exp);
++pstate->list_offset; ++pstate->list_offset;
scm_gen_putc (' ', port); scm_putc (' ', port);
/* CHECK_INTS; */ /* CHECK_INTS; */
scm_iprin1 (SCM_CAR (exp), port, pstate); scm_iprin1 (SCM_CAR (exp), port, pstate);
} }
} }
if (SCM_NNULLP (exp)) if (SCM_NNULLP (exp))
{ {
scm_gen_puts (scm_regular_string, " . ", port); scm_puts (" . ", port);
scm_iprin1 (exp, port, pstate); scm_iprin1 (exp, port, pstate);
} }
skip_tail: skip_tail:
@ -849,7 +842,7 @@ fancy_circref:
pstate->list_offset -= pstate->top - floor - 2; pstate->list_offset -= pstate->top - floor - 2;
circref: circref:
scm_gen_puts (scm_regular_string, " . ", port); scm_puts (" . ", port);
print_circref (port, pstate, exp); print_circref (port, pstate, exp);
goto end; goto end;
} }
@ -924,7 +917,7 @@ scm_newline (port)
else else
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG1, s_newline); SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG1, s_newline);
scm_gen_putc ('\n', SCM_COERCE_OPORT (port)); scm_putc ('\n', SCM_COERCE_OPORT (port));
#ifdef HAVE_PIPE #ifdef HAVE_PIPE
# ifdef EPIPE # ifdef EPIPE
if (EPIPE == errno) if (EPIPE == errno)
@ -950,7 +943,7 @@ scm_write_char (chr, port)
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write_char); SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write_char);
SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char); SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char);
scm_gen_putc ((int) SCM_ICHR (chr), SCM_COERCE_OPORT (port)); scm_putc ((int) SCM_ICHR (chr), SCM_COERCE_OPORT (port));
#ifdef HAVE_PIPE #ifdef HAVE_PIPE
# ifdef EPIPE # ifdef EPIPE
if (EPIPE == errno) if (EPIPE == errno)

100
libguile/read.c
View file

@ -40,14 +40,12 @@
* If you do not wish that, delete this exception notice. */ * If you do not wish that, delete this exception notice. */
#include "extchrs.h"
#include <stdio.h> #include <stdio.h>
#include "_scm.h" #include "_scm.h"
#include "chars.h" #include "chars.h"
#include "genio.h" #include "genio.h"
#include "eval.h" #include "eval.h"
#include "unif.h" #include "unif.h"
#include "mbstrings.h"
#include "kw.h" #include "kw.h"
#include "alist.h" #include "alist.h"
#include "srcprop.h" #include "srcprop.h"
@ -109,7 +107,7 @@ scm_read (port)
c = scm_flush_ws (port, (char *) NULL); c = scm_flush_ws (port, (char *) NULL);
if (EOF == c) if (EOF == c)
return SCM_EOF_VAL; return SCM_EOF_VAL;
scm_gen_ungetc (c, port); scm_ungetc (c, port);
tok_buf = scm_makstr (30L, 0); tok_buf = scm_makstr (30L, 0);
return scm_lreadr (&tok_buf, port, &copy); return scm_lreadr (&tok_buf, port, &copy);
@ -134,7 +132,7 @@ scm_flush_ws (port, eoferr)
{ {
register int c; register int c;
while (1) while (1)
switch (c = scm_gen_getc (port)) switch (c = scm_getc (port))
{ {
case EOF: case EOF:
goteof: goteof:
@ -143,7 +141,7 @@ scm_flush_ws (port, eoferr)
return c; return c;
case ';': case ';':
lp: lp:
switch (c = scm_gen_getc (port)) switch (c = scm_getc (port))
{ {
case EOF: case EOF:
goto goteof; goto goteof;
@ -254,7 +252,7 @@ skip_scsh_block_comment (port)
for (;;) for (;;)
{ {
int c = scm_gen_getc (port); int c = scm_getc (port);
if (c == EOF) if (c == EOF)
scm_wta (SCM_UNDEFINED, scm_wta (SCM_UNDEFINED,
@ -305,12 +303,12 @@ tryagain_no_flush_ws:
p = scm_i_quasiquote; p = scm_i_quasiquote;
goto recquote; goto recquote;
case ',': case ',':
c = scm_gen_getc (port); c = scm_getc (port);
if ('@' == c) if ('@' == c)
p = scm_i_uq_splicing; p = scm_i_uq_splicing;
else else
{ {
scm_gen_ungetc (c, port); scm_ungetc (c, port);
p = scm_i_unquote; p = scm_i_unquote;
} }
recquote: recquote:
@ -331,7 +329,7 @@ tryagain_no_flush_ws:
SCM_EOL)); SCM_EOL));
return p; return p;
case '#': case '#':
c = scm_gen_getc (port); c = scm_getc (port);
switch (c) switch (c)
{ {
case '(': case '(':
@ -357,7 +355,7 @@ tryagain_no_flush_ws:
case 'I': case 'I':
case 'e': case 'e':
case 'E': case 'E':
scm_gen_ungetc (c, port); scm_ungetc (c, port);
c = '#'; c = '#';
goto num; goto num;
@ -380,12 +378,10 @@ tryagain_no_flush_ws:
case '{': case '{':
j = scm_read_token (c, tok_buf, port, 1); j = scm_read_token (c, tok_buf, port, 1);
p = scm_intern (SCM_CHARS (*tok_buf), j); p = scm_intern (SCM_CHARS (*tok_buf), j);
if (SCM_PORT_REPRESENTATION (port) != scm_regular_port)
scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T);
return SCM_CAR (p); return SCM_CAR (p);
case '\\': case '\\':
c = scm_gen_getc (port); c = scm_getc (port);
j = scm_read_token (c, tok_buf, port, 0); j = scm_read_token (c, tok_buf, port, 0);
if (j == 1) if (j == 1)
return SCM_MAKICHR (c); return SCM_MAKICHR (c);
@ -405,8 +401,6 @@ tryagain_no_flush_ws:
case ':': case ':':
j = scm_read_token ('-', tok_buf, port, 0); j = scm_read_token ('-', tok_buf, port, 0);
p = scm_intern (SCM_CHARS (*tok_buf), j); p = scm_intern (SCM_CHARS (*tok_buf), j);
if (SCM_PORT_REPRESENTATION (port) != scm_regular_port)
scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T);
return scm_make_keyword_from_dash_symbol (SCM_CAR (p)); return scm_make_keyword_from_dash_symbol (SCM_CAR (p));
default: default:
@ -439,15 +433,15 @@ tryagain_no_flush_ws:
case '"': case '"':
j = 0; j = 0;
while ('"' != (c = scm_gen_getc (port))) while ('"' != (c = scm_getc (port)))
{ {
SCM_ASSERT (EOF != c, SCM_UNDEFINED, "end of file in ", "string"); SCM_ASSERT (EOF != c, SCM_UNDEFINED, "end of file in ", "string");
while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf)) while (j + 2 >= SCM_LENGTH (*tok_buf))
scm_grow_tok_buf (tok_buf); scm_grow_tok_buf (tok_buf);
if (c == '\\') if (c == '\\')
switch (c = scm_gen_getc (port)) switch (c = scm_getc (port))
{ {
case '\n': case '\n':
continue; continue;
@ -473,31 +467,15 @@ tryagain_no_flush_ws:
c = '\v'; c = '\v';
break; break;
} }
if (SCM_PORT_REPRESENTATION(port) == scm_regular_port)
{
SCM_CHARS (*tok_buf)[j] = c; SCM_CHARS (*tok_buf)[j] = c;
++j; ++j;
} }
else
{
int len;
len = xwctomb (SCM_CHARS (*tok_buf) + j, c);
if (len == 0)
len = 1;
SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read");
j += len;
}
}
if (j == 0) if (j == 0)
return scm_nullstr; return scm_nullstr;
SCM_CHARS (*tok_buf)[j] = 0; SCM_CHARS (*tok_buf)[j] = 0;
{ {
SCM str; SCM str;
str = scm_makfromstr (SCM_CHARS (*tok_buf), j, 0); str = scm_makfromstr (SCM_CHARS (*tok_buf), j, 0);
if (SCM_PORT_REPRESENTATION(port) != scm_regular_port)
{
SCM_SETLENGTH (str, SCM_LENGTH (str), scm_tc7_mb_string);
}
return str; return str;
} }
@ -513,9 +491,9 @@ tryagain_no_flush_ws:
return p; return p;
if (c == '#') if (c == '#')
{ {
if ((j == 2) && (scm_gen_getc (port) == '(')) if ((j == 2) && (scm_getc (port) == '('))
{ {
scm_gen_ungetc ('(', port); scm_ungetc ('(', port);
c = SCM_CHARS (*tok_buf)[1]; c = SCM_CHARS (*tok_buf)[1];
goto callshrp; goto callshrp;
} }
@ -528,8 +506,6 @@ tryagain_no_flush_ws:
{ {
j = scm_read_token ('-', tok_buf, port, 0); j = scm_read_token ('-', tok_buf, port, 0);
p = scm_intern (SCM_CHARS (*tok_buf), j); p = scm_intern (SCM_CHARS (*tok_buf), j);
if (SCM_PORT_REPRESENTATION (port) != scm_regular_port)
scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T);
return scm_make_keyword_from_dash_symbol (SCM_CAR (p)); return scm_make_keyword_from_dash_symbol (SCM_CAR (p));
} }
/* fallthrough */ /* fallthrough */
@ -539,8 +515,6 @@ tryagain_no_flush_ws:
tok: tok:
p = scm_intern (SCM_CHARS (*tok_buf), j); p = scm_intern (SCM_CHARS (*tok_buf), j);
if (SCM_PORT_REPRESENTATION (port) != scm_regular_port)
scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T);
return SCM_CAR (p); return SCM_CAR (p);
} }
} }
@ -568,29 +542,17 @@ scm_read_token (ic, tok_buf, port, weird)
else else
{ {
j = 0; j = 0;
while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf)) while (j + 2 >= SCM_LENGTH (*tok_buf))
p = scm_grow_tok_buf (tok_buf); p = scm_grow_tok_buf (tok_buf);
if (SCM_PORT_REPRESENTATION(port) == scm_regular_port)
{
p[j] = c; p[j] = c;
++j; ++j;
} }
else
{
int len;
len = xwctomb (p + j, c);
if (len == 0)
len = 1;
SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read");
j += len;
}
}
while (1) while (1)
{ {
while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf)) while (j + 2 >= SCM_LENGTH (*tok_buf))
p = scm_grow_tok_buf (tok_buf); p = scm_grow_tok_buf (tok_buf);
c = scm_gen_getc (port); c = scm_getc (port);
switch (c) switch (c)
{ {
case '(': case '(':
@ -602,7 +564,7 @@ scm_read_token (ic, tok_buf, port, weird)
if (weird) if (weird)
goto default_case; goto default_case;
scm_gen_ungetc (c, port); scm_ungetc (c, port);
case EOF: case EOF:
eof_case: eof_case:
p[j] = 0; p[j] = 0;
@ -612,7 +574,7 @@ scm_read_token (ic, tok_buf, port, weird)
goto default_case; goto default_case;
else else
{ {
c = scm_gen_getc (port); c = scm_getc (port);
if (c == EOF) if (c == EOF)
goto eof_case; goto eof_case;
else else
@ -622,7 +584,7 @@ scm_read_token (ic, tok_buf, port, weird)
if (!weird) if (!weird)
goto default_case; goto default_case;
c = scm_gen_getc (port); c = scm_getc (port);
if (c == '#') if (c == '#')
{ {
p[j] = 0; p[j] = 0;
@ -630,7 +592,7 @@ scm_read_token (ic, tok_buf, port, weird)
} }
else else
{ {
scm_gen_ungetc (c, port); scm_ungetc (c, port);
c = '}'; c = '}';
goto default_case; goto default_case;
} }
@ -639,21 +601,9 @@ scm_read_token (ic, tok_buf, port, weird)
default_case: default_case:
{ {
c = (SCM_CASE_INSENSITIVE_P ? scm_downcase(c) : c); c = (SCM_CASE_INSENSITIVE_P ? scm_downcase(c) : c);
if (SCM_PORT_REPRESENTATION(port) == scm_regular_port)
{
p[j] = c; p[j] = c;
++j; ++j;
} }
else
{
int len;
len = xwctomb (p + j, c);
if (len == 0)
len = 1;
SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read");
j += len;
}
}
} }
} }
@ -678,7 +628,7 @@ scm_lreadparen (tok_buf, port, name, copy)
c = scm_flush_ws (port, name); c = scm_flush_ws (port, name);
if (')' == c) if (')' == c)
return SCM_EOL; return SCM_EOL;
scm_gen_ungetc (c, port); scm_ungetc (c, port);
if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy))) if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy)))
{ {
ans = scm_lreadr (tok_buf, port, copy); ans = scm_lreadr (tok_buf, port, copy);
@ -690,7 +640,7 @@ scm_lreadparen (tok_buf, port, name, copy)
ans = tl = scm_cons (tmp, SCM_EOL); ans = tl = scm_cons (tmp, SCM_EOL);
while (')' != (c = scm_flush_ws (port, name))) while (')' != (c = scm_flush_ws (port, name)))
{ {
scm_gen_ungetc (c, port); scm_ungetc (c, port);
if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy))) if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy)))
{ {
SCM_SETCDR (tl, scm_lreadr (tok_buf, port, copy)); SCM_SETCDR (tl, scm_lreadr (tok_buf, port, copy));
@ -721,7 +671,7 @@ scm_lreadrecparen (tok_buf, port, name, copy)
c = scm_flush_ws (port, name); c = scm_flush_ws (port, name);
if (')' == c) if (')' == c)
return SCM_EOL; return SCM_EOL;
scm_gen_ungetc (c, port); scm_ungetc (c, port);
if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy))) if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy)))
{ {
ans = scm_lreadr (tok_buf, port, copy); ans = scm_lreadr (tok_buf, port, copy);
@ -738,7 +688,7 @@ scm_lreadrecparen (tok_buf, port, name, copy)
SCM_EOL); SCM_EOL);
while (')' != (c = scm_flush_ws (port, name))) while (')' != (c = scm_flush_ws (port, name)))
{ {
scm_gen_ungetc (c, port); scm_ungetc (c, port);
if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy))) if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy)))
{ {
SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, copy)); SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, copy));

4
libguile/regex-posix.c
View file

@ -104,9 +104,9 @@ scm_print_regex_t (obj, port, pstate)
{ {
regex_t *r; regex_t *r;
r = SCM_RGX (obj); r = SCM_RGX (obj);
scm_gen_puts (scm_regular_string, "#<rgx ", port); scm_puts ("#<rgx ", port);
scm_intprint (obj, 16, port); scm_intprint (obj, 16, port);
scm_gen_puts (scm_regular_string, ">", port); scm_puts (">", port);
return 1; return 1;
} }

6
libguile/root.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996 Free Software Foundation, Inc. /* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -115,9 +115,9 @@ print_root (exp, port, pstate)
SCM port; SCM port;
scm_print_state *pstate; scm_print_state *pstate;
{ {
scm_gen_puts (scm_regular_string, "#<root ", port); scm_puts ("#<root ", port);
scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port); scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
scm_gen_putc('>', port); scm_putc('>', port);
return 1; return 1;
} }

6
libguile/srcprop.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996 Free Software Foundation /* Copyright (C) 1995,1996, 1997 Free Software Foundation
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -114,11 +114,11 @@ prinsrcprops (obj, port, pstate)
scm_print_state *pstate; scm_print_state *pstate;
{ {
int writingp = SCM_WRITINGP (pstate); int writingp = SCM_WRITINGP (pstate);
scm_gen_puts (scm_regular_string, "#<srcprops ", port); scm_puts ("#<srcprops ", port);
SCM_SET_WRITINGP (pstate, 1); SCM_SET_WRITINGP (pstate, 1);
scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate); scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate);
SCM_SET_WRITINGP (pstate, writingp); SCM_SET_WRITINGP (pstate, writingp);
scm_gen_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
} }

8
libguile/stackchk.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996 Free Software Foundation, Inc. /* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -87,11 +87,11 @@ scm_stack_report ()
SCM_STACKITEM stack; SCM_STACKITEM stack;
scm_intprint (scm_stack_size (SCM_BASE (scm_rootcont)) * sizeof (SCM_STACKITEM), scm_intprint (scm_stack_size (SCM_BASE (scm_rootcont)) * sizeof (SCM_STACKITEM),
16, scm_cur_errp); 16, scm_cur_errp);
scm_gen_puts (scm_regular_string, " of stack: 0x", scm_cur_errp); scm_puts (" of stack: 0x", scm_cur_errp);
scm_intprint ((long) SCM_BASE (scm_rootcont), 16, scm_cur_errp); scm_intprint ((long) SCM_BASE (scm_rootcont), 16, scm_cur_errp);
scm_gen_puts (scm_regular_string, " - 0x", scm_cur_errp); scm_puts (" - 0x", scm_cur_errp);
scm_intprint ((long) &stack, 16, scm_cur_errp); scm_intprint ((long) &stack, 16, scm_cur_errp);
scm_gen_puts (scm_regular_string, "\n", scm_cur_errp); scm_puts ("\n", scm_cur_errp);
} }

1
libguile/strop.c
View file

@ -257,7 +257,6 @@ SCM
scm_string_copy (str) scm_string_copy (str)
SCM str; SCM str;
{ {
/* doesn't handle multibyte strings. */
SCM_ASSERT (SCM_NIMP (str) && (SCM_STRINGP (str) || SCM_SUBSTRP (str)), SCM_ASSERT (SCM_NIMP (str) && (SCM_STRINGP (str) || SCM_SUBSTRP (str)),
str, SCM_ARG1, s_string_copy); str, SCM_ARG1, s_string_copy);
return scm_makfromstr (SCM_ROCHARS (str), (scm_sizet)SCM_ROLENGTH (str), 0); return scm_makfromstr (SCM_ROCHARS (str), (scm_sizet)SCM_ROLENGTH (str), 0);

9
libguile/struct.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1996 Free Software Foundation, Inc. /* Copyright (C) 1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -607,12 +607,11 @@ scm_print_struct (exp, port, pstate)
scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate); scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate);
else else
{ {
scm_gen_write (scm_regular_string, "#<struct ", sizeof ("#<struct ") - 1, scm_lfwrite ("#<struct ", sizeof ("#<struct ") - 1, port);
port);
scm_intprint (SCM_STRUCT_VTABLE (exp), 16, port); scm_intprint (SCM_STRUCT_VTABLE (exp), 16, port);
scm_gen_putc (':', port); scm_putc (':', port);
scm_intprint (exp, 16, port); scm_intprint (exp, 16, port);
scm_gen_putc ('>', port); scm_putc ('>', port);
} }
} }

17
libguile/symbols.c
View file

@ -46,7 +46,6 @@
#include "eval.h" #include "eval.h"
#include "variable.h" #include "variable.h"
#include "alist.h" #include "alist.h"
#include "mbstrings.h"
#include "weaks.h" #include "weaks.h"
#include "symbols.h" #include "symbols.h"
@ -298,7 +297,6 @@ scm_intern_obarray_soft (name, len, obarray, softness)
lsym = scm_makfromstr (name, len, SCM_SYMBOL_SLOTS); lsym = scm_makfromstr (name, len, SCM_SYMBOL_SLOTS);
SCM_SETLENGTH (lsym, (long) len, scm_tc7_msymbol); SCM_SETLENGTH (lsym, (long) len, scm_tc7_msymbol);
SCM_SYMBOL_MULTI_BYTE_STRINGP (lsym) = SCM_BOOL_F;
SCM_SYMBOL_HASH (lsym) = scm_hash; SCM_SYMBOL_HASH (lsym) = scm_hash;
SCM_SYMBOL_PROPS (lsym) = SCM_EOL; SCM_SYMBOL_PROPS (lsym) = SCM_EOL;
if (obarray == SCM_BOOL_F) if (obarray == SCM_BOOL_F)
@ -474,13 +472,6 @@ scm_string_to_symbol(s)
SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG1, s_string_to_symbol); SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG1, s_string_to_symbol);
vcell = scm_intern(SCM_ROCHARS(s), (scm_sizet)SCM_LENGTH(s)); vcell = scm_intern(SCM_ROCHARS(s), (scm_sizet)SCM_LENGTH(s));
answer = SCM_CAR (vcell); answer = SCM_CAR (vcell);
if (SCM_TYP7 (answer) == scm_tc7_msymbol)
{
if (SCM_REGULAR_STRINGP (s))
SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F;
else
SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T;
}
return answer; return answer;
} }
@ -520,13 +511,6 @@ scm_string_to_obarray_symbol(o, s, softp)
if (vcell == SCM_BOOL_F) if (vcell == SCM_BOOL_F)
return vcell; return vcell;
answer = SCM_CAR (vcell); answer = SCM_CAR (vcell);
if (SCM_TYP7 (s) == scm_tc7_msymbol)
{
if (SCM_REGULAR_STRINGP (s))
SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F;
else
SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T;
}
return answer; return answer;
} }
@ -689,7 +673,6 @@ msymbolize (s)
string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS); string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS);
SCM_SETCHARS (s, SCM_CHARS (string)); SCM_SETCHARS (s, SCM_CHARS (string));
SCM_SETLENGTH (s, SCM_LENGTH (s), scm_tc7_msymbol); SCM_SETLENGTH (s, SCM_LENGTH (s), scm_tc7_msymbol);
SCM_SYMBOL_MULTI_BYTE_STRINGP (s) = SCM_BOOL_F;
SCM_SETCDR (string, SCM_EOL); SCM_SETCDR (string, SCM_EOL);
SCM_SETCAR (string, SCM_EOL); SCM_SETCAR (string, SCM_EOL);
SCM_SYMBOL_PROPS (s) = SCM_EOL; SCM_SYMBOL_PROPS (s) = SCM_EOL;

10
libguile/symbols.h
View file

@ -59,9 +59,8 @@ extern int scm_symhash_dim;
and that's it. They use the scm_tc7_ssymbol tag (S bit clear). and that's it. They use the scm_tc7_ssymbol tag (S bit clear).
Msymbols are symbols with extra slots. These slots hold a property Msymbols are symbols with extra slots. These slots hold a property
list and a function value (for Emacs Lisp compatibility), a hash list and a function value (for Emacs Lisp compatibility), and a hash
code, and a flag to indicate whether their name contains multibyte code. They use the scm_tc7_msymbol tag.
characters. They use the scm_tc7_msymbol tag.
We'd like SCM_CHARS to work on msymbols just as it does on We'd like SCM_CHARS to work on msymbols just as it does on
ssymbols, so we'll have it point to the symbol's name as usual, and ssymbols, so we'll have it point to the symbol's name as usual, and
@ -82,13 +81,12 @@ extern int scm_symhash_dim;
#define SCM_CHARS(x) ((char *)(SCM_CDR(x))) #define SCM_CHARS(x) ((char *)(SCM_CDR(x)))
#define SCM_UCHARS(x) ((unsigned char *)(SCM_CDR(x))) #define SCM_UCHARS(x) ((unsigned char *)(SCM_CDR(x)))
#define SCM_SLOTS(x) ((SCM *) (* ((SCM *)SCM_CHARS(x) - 1))) #define SCM_SLOTS(x) ((SCM *) (* ((SCM *)SCM_CHARS(x) - 1)))
#define SCM_SYMBOL_SLOTS 5 #define SCM_SYMBOL_SLOTS 4
#define SCM_SYMBOL_FUNC(X) (SCM_SLOTS(X)[0]) #define SCM_SYMBOL_FUNC(X) (SCM_SLOTS(X)[0])
#define SCM_SYMBOL_PROPS(X) (SCM_SLOTS(X)[1]) #define SCM_SYMBOL_PROPS(X) (SCM_SLOTS(X)[1])
#define SCM_SYMBOL_HASH(X) (*(unsigned long*)(&SCM_SLOTS(X)[2])) #define SCM_SYMBOL_HASH(X) (*(unsigned long*)(&SCM_SLOTS(X)[2]))
#define SCM_SYMBOL_MULTI_BYTE_STRINGP(X) (*(unsigned long*)(&SCM_SLOTS(X)[3]))
#define SCM_ROSTRINGP(x) ((SCM_TYP7SD(x)==scm_tc7_string) || (SCM_TYP7S(x) == scm_tc7_ssymbol)) #define SCM_ROSTRINGP(x) ((SCM_TYP7S(x)==scm_tc7_string) || (SCM_TYP7S(x) == scm_tc7_ssymbol))
#define SCM_ROCHARS(x) ((SCM_TYP7(x) == scm_tc7_substring) \ #define SCM_ROCHARS(x) ((SCM_TYP7(x) == scm_tc7_substring) \
? SCM_INUM (SCM_CADR (x)) + SCM_CHARS (SCM_CDDR (x)) \ ? SCM_INUM (SCM_CADR (x)) + SCM_CHARS (SCM_CDDR (x)) \
: SCM_CHARS (x)) : SCM_CHARS (x))

8
libguile/tag.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1996 Free Software Foundation, Inc. /* Copyright (C) 1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -63,9 +63,7 @@ SCM_CONST_LONG (scm_utag_fvect, "utag_fvect", 12);
SCM_CONST_LONG (scm_utag_dvect, "utag_dvect", 13); SCM_CONST_LONG (scm_utag_dvect, "utag_dvect", 13);
SCM_CONST_LONG (scm_utag_cvect, "utag_cvect", 14); SCM_CONST_LONG (scm_utag_cvect, "utag_cvect", 14);
SCM_CONST_LONG (scm_utag_string, "utag_string", 15); SCM_CONST_LONG (scm_utag_string, "utag_string", 15);
SCM_CONST_LONG (scm_utag_mb_string, "utag_mb_string", 16);
SCM_CONST_LONG (scm_utag_substring, "utag_substring", 17); SCM_CONST_LONG (scm_utag_substring, "utag_substring", 17);
SCM_CONST_LONG (scm_utag_mb_substring, "utag_mb_substring", 18);
SCM_CONST_LONG (scm_utag_asubr, "utag_asubr", 19); SCM_CONST_LONG (scm_utag_asubr, "utag_asubr", 19);
SCM_CONST_LONG (scm_utag_subr_0, "utag_subr_0", 20); SCM_CONST_LONG (scm_utag_subr_0, "utag_subr_0", 20);
SCM_CONST_LONG (scm_utag_subr_1, "utag_subr_1", 21); SCM_CONST_LONG (scm_utag_subr_1, "utag_subr_1", 21);
@ -136,12 +134,8 @@ scm_tag (x)
return SCM_CDR (scm_utag_cvect) ; return SCM_CDR (scm_utag_cvect) ;
case scm_tc7_string: case scm_tc7_string:
return SCM_CDR (scm_utag_string) ; return SCM_CDR (scm_utag_string) ;
case scm_tc7_mb_string:
return SCM_CDR (scm_utag_mb_string) ;
case scm_tc7_substring: case scm_tc7_substring:
return SCM_CDR (scm_utag_substring) ; return SCM_CDR (scm_utag_substring) ;
case scm_tc7_mb_substring:
return SCM_CDR (scm_utag_mb_substring) ;
case scm_tc7_asubr: case scm_tc7_asubr:
return SCM_CDR (scm_utag_asubr) ; return SCM_CDR (scm_utag_asubr) ;
case scm_tc7_subr_0: case scm_tc7_subr_0:

25
libguile/tags.h
View file

@ -2,7 +2,7 @@
#ifndef TAGSH #ifndef TAGSH
#define TAGSH #define TAGSH
/* Copyright (C) 1995,1996 Free Software Foundation, Inc. /* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -218,31 +218,20 @@ typedef long SCM;
* bits) can be masked off to reveal a common type. * bits) can be masked off to reveal a common type.
* *
* TYP7S(X) returns TYP7, but masking out the option bit S. * TYP7S(X) returns TYP7, but masking out the option bit S.
* TYP7D(X) returns TYP7, but masking out the option bit D.
* TYP7SD(X) masks out both option bits.
* *
* For example, all strings have 001 in the 'xxx' bits in * For example, all strings have 001 in the 'xxx' bits in
* the diagram above, the D bit says whether it's a * the diagram above, the D bit says whether it's a
* substring, and the S bit says whether it's a multibyte * substring.
* character string.
* *
* for example: * for example:
* D S * S
* scm_tc7_string = G0010101 * scm_tc7_string = G0010101
* scm_tc7_mb_string = G0010111
* scm_tc7_substring = G0011101 * scm_tc7_substring = G0011101
* scm_tc7_mb_substring = G0011111
* *
* TYP7DS turns all string tags into tc7_string; thus, * TYP7S turns all string tags into tc7_string; thus,
* testing TYP7DS against tc7_string is a quick way to * testing TYP7S against tc7_string is a quick way to
* test for any kind of string. * test for any kind of string.
* *
* TYP7S turns tc7_mb_string into tc7_string and
* tc7_mb_substring into tc7_substring.
*
* TYP7D turns tc7_mb_substring into tc7_mb_string and
* tc7_substring into tc7_string.
*
* Some TC7 types are subdivided into 256 subtypes giving * Some TC7 types are subdivided into 256 subtypes giving
* rise to the macros: * rise to the macros:
* *
@ -312,8 +301,6 @@ typedef long SCM;
#define SCM_TYP7(x) (0x7f & (int)SCM_CAR(x)) #define SCM_TYP7(x) (0x7f & (int)SCM_CAR(x))
#define SCM_TYP7S(x) (0x7d & (int)SCM_CAR(x)) #define SCM_TYP7S(x) (0x7d & (int)SCM_CAR(x))
#define SCM_TYP7SD(x) (0x75 & (int)SCM_CAR(x))
#define SCM_TYP7D(x) (0x77 & (int)SCM_CAR(x))
#define SCM_TYP16(x) (0xffff & (int)SCM_CAR(x)) #define SCM_TYP16(x) (0xffff & (int)SCM_CAR(x))
@ -344,9 +331,7 @@ typedef long SCM;
/* a quad, two couples, two trists */ /* a quad, two couples, two trists */
#define scm_tc7_string 21 #define scm_tc7_string 21
#define scm_tc7_mb_string 23
#define scm_tc7_substring 29 #define scm_tc7_substring 29
#define scm_tc7_mb_substring 31
/* Many of the following should be turned /* Many of the following should be turned
* into structs or smobs. We need back some * into structs or smobs. We need back some

14
libguile/threads.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. /* Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -87,9 +87,9 @@ print_thread (exp, port, pstate)
SCM port; SCM port;
scm_print_state *pstate; scm_print_state *pstate;
{ {
scm_gen_puts (scm_regular_string, "#<thread ", port); scm_puts ("#<thread ", port);
scm_intprint (SCM_CDR (exp), 16, port); scm_intprint (SCM_CDR (exp), 16, port);
scm_gen_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
} }
@ -107,9 +107,9 @@ print_mutex (exp, port, pstate)
SCM port; SCM port;
scm_print_state *pstate; scm_print_state *pstate;
{ {
scm_gen_puts (scm_regular_string, "#<mutex ", port); scm_puts ("#<mutex ", port);
scm_intprint (SCM_CDR (exp), 16, port); scm_intprint (SCM_CDR (exp), 16, port);
scm_gen_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
} }
@ -127,9 +127,9 @@ print_condvar (exp, port, pstate)
SCM port; SCM port;
scm_print_state *pstate; scm_print_state *pstate;
{ {
scm_gen_puts (scm_regular_string, "#<condition-variable ", port); scm_puts ("#<condition-variable ", port);
scm_intprint (SCM_CDR (exp), 16, port); scm_intprint (SCM_CDR (exp), 16, port);
scm_gen_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
} }

18
libguile/throw.c
View file

@ -94,10 +94,10 @@ printjb (exp, port, pstate)
SCM port; SCM port;
scm_print_state *pstate; scm_print_state *pstate;
{ {
scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port); scm_puts ("#<jmpbuffer ", port);
scm_gen_puts (scm_regular_string, JBACTIVE(exp) ? "(active) " : "(inactive) ", port); scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
scm_intprint((SCM) JBJMPBUF(exp), 16, port); scm_intprint((SCM) JBJMPBUF(exp), 16, port);
scm_gen_putc ('>', port); scm_putc ('>', port);
return 1 ; return 1 ;
} }
@ -273,7 +273,7 @@ print_lazy_catch (SCM closure, SCM port, scm_print_state *pstate)
sprintf (buf, "#<lazy-catch 0x%lx 0x%lx>", sprintf (buf, "#<lazy-catch 0x%lx 0x%lx>",
(long) c->handler, (long) c->handler_data); (long) c->handler, (long) c->handler_data);
scm_gen_puts (scm_regular_string, buf, port); scm_puts (buf, port);
return 1; return 1;
} }
@ -489,8 +489,8 @@ handler_message (void *handler_data, SCM tag, SCM args)
if (! prog_name) if (! prog_name)
prog_name = "guile"; prog_name = "guile";
scm_gen_puts (scm_regular_string, prog_name, p); scm_puts (prog_name, p);
scm_gen_puts (scm_regular_string, ": ", p); scm_puts (": ", p);
if (scm_ilength (args) >= 3) if (scm_ilength (args) >= 3)
{ {
@ -501,11 +501,11 @@ handler_message (void *handler_data, SCM tag, SCM args)
} }
else else
{ {
scm_gen_puts (scm_regular_string, "uncaught throw to ", p); scm_puts ("uncaught throw to ", p);
scm_prin1 (tag, p, 0); scm_prin1 (tag, p, 0);
scm_gen_puts (scm_regular_string, ": ", p); scm_puts (": ", p);
scm_prin1 (args, p, 1); scm_prin1 (args, p, 1);
scm_gen_putc ('\n', p); scm_putc ('\n', p);
} }
} }

65
libguile/unif.c
View file

@ -99,7 +99,6 @@ scm_vector_set_length_x (vect, len)
default: default:
badarg1: scm_wta (vect, (char *) SCM_ARG1, s_vector_set_length_x); badarg1: scm_wta (vect, (char *) SCM_ARG1, s_vector_set_length_x);
case scm_tc7_string: case scm_tc7_string:
case scm_tc7_mb_string:
SCM_ASRTGO (vect != scm_nullstr, badarg1); SCM_ASRTGO (vect != scm_nullstr, badarg1);
sz = sizeof (char); sz = sizeof (char);
l++; l++;
@ -2228,7 +2227,7 @@ tail:
scm_iprin1 (ra, port, pstate); scm_iprin1 (ra, port, pstate);
for (j += inc; n-- > 0; j += inc) for (j += inc; n-- > 0; j += inc)
{ {
scm_gen_putc (' ', port); scm_putc (' ', port);
SCM_ARRAY_BASE (ra) = j; SCM_ARRAY_BASE (ra) = j;
scm_iprin1 (ra, port, pstate); scm_iprin1 (ra, port, pstate);
} }
@ -2240,16 +2239,16 @@ tail:
inc = SCM_ARRAY_DIMS (ra)[k].inc; inc = SCM_ARRAY_DIMS (ra)[k].inc;
for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++) for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++)
{ {
scm_gen_putc ('(', port); scm_putc ('(', port);
rapr1 (ra, j, k + 1, port, pstate); rapr1 (ra, j, k + 1, port, pstate);
scm_gen_puts (scm_regular_string, ") ", port); scm_puts (") ", port);
j += inc; j += inc;
} }
if (i == SCM_ARRAY_DIMS (ra)[k].ubnd) if (i == SCM_ARRAY_DIMS (ra)[k].ubnd)
{ /* could be zero size. */ { /* could be zero size. */
scm_gen_putc ('(', port); scm_putc ('(', port);
rapr1 (ra, j, k + 1, port, pstate); rapr1 (ra, j, k + 1, port, pstate);
scm_gen_putc (')', port); scm_putc (')', port);
} }
break; break;
} }
@ -2268,7 +2267,7 @@ tail:
scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate); scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate);
for (j += inc; n-- > 0; j += inc) for (j += inc; n-- > 0; j += inc)
{ {
scm_gen_putc (' ', port); scm_putc (' ', port);
scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate); scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate);
} }
break; break;
@ -2278,19 +2277,19 @@ tail:
if (SCM_WRITINGP (pstate)) if (SCM_WRITINGP (pstate))
for (j += inc; n-- > 0; j += inc) for (j += inc; n-- > 0; j += inc)
{ {
scm_gen_putc (' ', port); scm_putc (' ', port);
scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate); scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate);
} }
else else
for (j += inc; n-- > 0; j += inc) for (j += inc; n-- > 0; j += inc)
scm_gen_putc (SCM_CHARS (ra)[j], port); scm_putc (SCM_CHARS (ra)[j], port);
break; break;
case scm_tc7_byvect: case scm_tc7_byvect:
if (n-- > 0) if (n-- > 0)
scm_intprint (((char *)SCM_CDR (ra))[j], 10, port); scm_intprint (((char *)SCM_CDR (ra))[j], 10, port);
for (j += inc; n-- > 0; j += inc) for (j += inc; n-- > 0; j += inc)
{ {
scm_gen_putc (' ', port); scm_putc (' ', port);
scm_intprint (((char *)SCM_CDR (ra))[j], 10, port); scm_intprint (((char *)SCM_CDR (ra))[j], 10, port);
} }
break; break;
@ -2301,7 +2300,7 @@ tail:
scm_intprint (SCM_VELTS (ra)[j], 10, port); scm_intprint (SCM_VELTS (ra)[j], 10, port);
for (j += inc; n-- > 0; j += inc) for (j += inc; n-- > 0; j += inc)
{ {
scm_gen_putc (' ', port); scm_putc (' ', port);
scm_intprint (SCM_VELTS (ra)[j], 10, port); scm_intprint (SCM_VELTS (ra)[j], 10, port);
} }
break; break;
@ -2311,7 +2310,7 @@ tail:
scm_intprint (((short *)SCM_CDR (ra))[j], 10, port); scm_intprint (((short *)SCM_CDR (ra))[j], 10, port);
for (j += inc; n-- > 0; j += inc) for (j += inc; n-- > 0; j += inc)
{ {
scm_gen_putc (' ', port); scm_putc (' ', port);
scm_intprint (((short *)SCM_CDR (ra))[j], 10, port); scm_intprint (((short *)SCM_CDR (ra))[j], 10, port);
} }
break; break;
@ -2326,7 +2325,7 @@ tail:
scm_floprint (z, port, pstate); scm_floprint (z, port, pstate);
for (j += inc; n-- > 0; j += inc) for (j += inc; n-- > 0; j += inc)
{ {
scm_gen_putc (' ', port); scm_putc (' ', port);
SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j]; SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
scm_floprint (z, port, pstate); scm_floprint (z, port, pstate);
} }
@ -2341,7 +2340,7 @@ tail:
scm_floprint (z, port, pstate); scm_floprint (z, port, pstate);
for (j += inc; n-- > 0; j += inc) for (j += inc; n-- > 0; j += inc)
{ {
scm_gen_putc (' ', port); scm_putc (' ', port);
SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j]; SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
scm_floprint (z, port, pstate); scm_floprint (z, port, pstate);
} }
@ -2356,7 +2355,7 @@ tail:
scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate); scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
for (j += inc; n-- > 0; j += inc) for (j += inc; n-- > 0; j += inc)
{ {
scm_gen_putc (' ', port); scm_putc (' ', port);
SCM_REAL (z) = SCM_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j]; SCM_REAL (z) = SCM_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1]; SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate); scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
@ -2377,7 +2376,7 @@ scm_raprin1 (exp, port, pstate)
{ {
SCM v = exp; SCM v = exp;
scm_sizet base = 0; scm_sizet base = 0;
scm_gen_putc ('#', port); scm_putc ('#', port);
tail: tail:
switch SCM_TYP7 switch SCM_TYP7
(v) (v)
@ -2390,9 +2389,9 @@ tail:
if (SCM_ARRAYP (v)) if (SCM_ARRAYP (v))
{ {
scm_gen_puts (scm_regular_string, "<enclosed-array ", port); scm_puts ("<enclosed-array ", port);
rapr1 (exp, base, 0, port, pstate); rapr1 (exp, base, 0, port, pstate);
scm_gen_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
} }
else else
@ -2405,13 +2404,13 @@ tail:
if (exp == v) if (exp == v)
{ /* a uve, not an scm_array */ { /* a uve, not an scm_array */
register long i, j, w; register long i, j, w;
scm_gen_putc ('*', port); scm_putc ('*', port);
for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++) for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++)
{ {
w = SCM_VELTS (exp)[i]; w = SCM_VELTS (exp)[i];
for (j = SCM_LONG_BIT; j; j--) for (j = SCM_LONG_BIT; j; j--)
{ {
scm_gen_putc (w & 1 ? '1' : '0', port); scm_putc (w & 1 ? '1' : '0', port);
w >>= 1; w >>= 1;
} }
} }
@ -2421,52 +2420,52 @@ tail:
w = SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT]; w = SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT];
for (; j; j--) for (; j; j--)
{ {
scm_gen_putc (w & 1 ? '1' : '0', port); scm_putc (w & 1 ? '1' : '0', port);
w >>= 1; w >>= 1;
} }
} }
return 1; return 1;
} }
else else
scm_gen_putc ('b', port); scm_putc ('b', port);
break; break;
case scm_tc7_string: case scm_tc7_string:
scm_gen_putc ('a', port); scm_putc ('a', port);
break; break;
case scm_tc7_byvect: case scm_tc7_byvect:
scm_gen_puts (scm_regular_string, "bytes", port); scm_puts ("bytes", port);
break; break;
case scm_tc7_uvect: case scm_tc7_uvect:
scm_gen_putc ('u', port); scm_putc ('u', port);
break; break;
case scm_tc7_ivect: case scm_tc7_ivect:
scm_gen_putc ('e', port); scm_putc ('e', port);
break; break;
case scm_tc7_svect: case scm_tc7_svect:
scm_gen_puts (scm_regular_string, "short", port); scm_puts ("short", port);
break; break;
#ifdef LONGLONGS #ifdef LONGLONGS
case scm_tc7_llvect: case scm_tc7_llvect:
scm_gen_puts (scm_regular_string, "long_long", port); scm_puts ("long_long", port);
break; break;
#endif #endif
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
#ifdef SCM_SINGLES #ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
scm_gen_putc ('s', port); scm_putc ('s', port);
break; break;
#endif /*SCM_SINGLES*/ #endif /*SCM_SINGLES*/
case scm_tc7_dvect: case scm_tc7_dvect:
scm_gen_putc ('i', port); scm_putc ('i', port);
break; break;
case scm_tc7_cvect: case scm_tc7_cvect:
scm_gen_putc ('c', port); scm_putc ('c', port);
break; break;
#endif /*SCM_FLOATS*/ #endif /*SCM_FLOATS*/
} }
scm_gen_putc ('(', port); scm_putc ('(', port);
rapr1 (exp, base, 0, port, pstate); rapr1 (exp, base, 0, port, pstate);
scm_gen_putc (')', port); scm_putc (')', port);
return 1; return 1;
} }

10
libguile/variable.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996 Free Software Foundation, Inc. /* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -68,20 +68,20 @@ prin_var (exp, port, pstate)
SCM port; SCM port;
scm_print_state *pstate; scm_print_state *pstate;
{ {
scm_gen_puts (scm_regular_string, "#<variable ", port); scm_puts ("#<variable ", port);
scm_intprint(exp, 16, port); scm_intprint(exp, 16, port);
{ {
SCM val_cell; SCM val_cell;
val_cell = SCM_CDR(exp); val_cell = SCM_CDR(exp);
if (SCM_CAR (val_cell) != SCM_UNDEFINED) if (SCM_CAR (val_cell) != SCM_UNDEFINED)
{ {
scm_gen_puts (scm_regular_string, " name: ", port); scm_puts (" name: ", port);
scm_iprin1 (SCM_CAR (val_cell), port, pstate); scm_iprin1 (SCM_CAR (val_cell), port, pstate);
} }
scm_gen_puts (scm_regular_string, " binding: ", port); scm_puts (" binding: ", port);
scm_iprin1 (SCM_CDR (val_cell), port, pstate); scm_iprin1 (SCM_CDR (val_cell), port, pstate);
} }
scm_gen_putc('>', port); scm_putc('>', port);
return 1; return 1;
} }