summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--NEWS4
-rw-r--r--RELEASE2
-rw-r--r--libguile/backtrace.c16
-rw-r--r--libguile/fports.c14
-rw-r--r--libguile/gc.c6
-rw-r--r--libguile/gh_data.c27
-rw-r--r--libguile/goops.c2
-rw-r--r--libguile/objects.c2
-rw-r--r--libguile/ports.c5
-rw-r--r--libguile/ports.h1
-rw-r--r--libguile/print.c23
-rw-r--r--libguile/symbols.h4
12 files changed, 55 insertions, 51 deletions
diff --git a/NEWS b/NEWS
index 60db8e26d..5a9c3e204 100644
--- a/NEWS
+++ b/NEWS
@@ -227,7 +227,8 @@ SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SYMBOL_SLOTS, SCM_SLOTS, SCM_SLOPPY_STRINGP,
SCM_VALIDATE_STRINGORSUBSTR, SCM_FREEP, SCM_NFREEP, SCM_CHARS, SCM_UCHARS,
SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY,
SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH,
-SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR
+SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR,
+SCM_ROSTRINGP
Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE.
Use scm_memory_error instead of SCM_NALLOC.
@@ -238,6 +239,7 @@ Use a type specific accessor macro instead of SCM_CHARS/SCM_UCHARS.
Use a type specific accessor instead of SCM(_|_RO|_HUGE_)LENGTH.
Use SCM_VALIDATE_(SYMBOL|STRING) instead of SCM_VALIDATE_ROSTRING.
Use SCM_STRING_COERCE_0TERMINATION_X instead of SCM_COERCE_SUBSTR.
+Use SCM_STRINGP or SCM_SYMBOLP instead of SCM_ROSTRINGP.
** Removed function: scm_struct_init
diff --git a/RELEASE b/RELEASE
index e2773c54d..37c17ffda 100644
--- a/RELEASE
+++ b/RELEASE
@@ -49,7 +49,7 @@ In release 1.6:
SCM_FREEP, SCM_NFREEP, SCM_CHARS, SCM_UCHARS, SCM_VALIDATE_ROSTRING,
SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH,
SCM_LENGTH, SCM_HUGE_LENGTH, SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET,
- SCM_COERCE_SUBSTR
+ SCM_COERCE_SUBSTR, SCM_ROSTRINGP
- remove scm_vector_set_length_x
- remove function scm_call_catching_errors
(replaced by catch functions from throw.[ch])
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index 7a8ee3a47..6c2b4e3d8 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -110,15 +110,15 @@ display_header (SCM source, SCM port)
void
scm_display_error_message (SCM message, SCM args, SCM port)
{
- if (SCM_ROSTRINGP (message) && SCM_NFALSEP (scm_list_p (args)))
+ if (SCM_STRINGP (message) && !SCM_FALSEP (scm_list_p (args)))
{
scm_simple_format (port, message, args);
scm_newline (port);
}
else
{
- scm_prin1 (message, port, 0);
- scm_putc ('\n', port);
+ scm_display (message, port);
+ scm_newline (port);
}
}
@@ -131,7 +131,7 @@ display_expression (SCM frame,SCM pname,SCM source,SCM port)
pstate->fancyp = 1;
pstate->level = 2;
pstate->length = 3;
- if (SCM_ROSTRINGP (pname))
+ if (SCM_SYMBOLP (pname) || SCM_STRINGP (pname))
{
if (SCM_FRAMEP (frame)
&& SCM_FRAME_EVAL_ARGS_P (frame))
@@ -170,8 +170,8 @@ display_error_body (struct display_error_args *a)
{
SCM current_frame = SCM_BOOL_F;
SCM source = SCM_BOOL_F;
- SCM pname = SCM_BOOL_F;
SCM prev_frame = SCM_BOOL_F;
+ SCM pname = a->subr;
if (SCM_DEBUGGINGP
&& SCM_STACKP (a->stack)
@@ -182,13 +182,11 @@ display_error_body (struct display_error_args *a)
prev_frame = SCM_FRAME_PREV (current_frame);
if (!SCM_MEMOIZEDP (source) && !SCM_FALSEP (prev_frame))
source = SCM_FRAME_SOURCE (prev_frame);
- if (SCM_FRAME_PROC_P (current_frame)
+ if (!SCM_SYMBOLP (pname) && !SCM_STRINGP (pname) && SCM_FRAME_PROC_P (current_frame)
&& SCM_EQ_P (scm_procedure_p (SCM_FRAME_PROC (current_frame)), SCM_BOOL_T))
pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
}
- if (!SCM_ROSTRINGP (pname))
- pname = a->subr;
- if (SCM_ROSTRINGP (pname) || SCM_MEMOIZEDP (source))
+ if (SCM_SYMBOLP (pname) || SCM_STRINGP (pname) || SCM_MEMOIZEDP (source))
{
display_header (source, a->port);
display_expression (current_frame, pname, source, a->port);
diff --git a/libguile/fports.c b/libguile/fports.c
index 658ab2675..046bdf60a 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -77,7 +77,7 @@ static void
scm_fport_buffer_add (SCM port, int read_size, int write_size)
{
struct scm_fport *fp = SCM_FSTREAM (port);
- scm_port *pt = SCM_PTAB_ENTRY (port);
+ scm_port *pt = SCM_PTAB_ENTRY (port);
char *s_scm_fport_buffer_add = "scm_fport_buffer_add";
if (read_size == -1 || write_size == -1)
@@ -377,7 +377,7 @@ scm_fdes_to_port (int fdes, char *mode, SCM name)
else
scm_fport_buffer_add (port, -1, -1);
}
- SCM_PTAB_ENTRY (port)->file_name = name;
+ SCM_SET_FILENAME (port, name);
SCM_ALLOW_INTS;
return port;
}
@@ -429,11 +429,11 @@ prinfport (SCM exp,SCM port,scm_print_state *pstate)
if (SCM_OPFPORTP (exp))
{
int fdes;
- SCM name = SCM_PTAB_ENTRY (exp)->file_name;
- scm_puts (SCM_ROSTRINGP (name)
- ? SCM_ROCHARS (name)
- : SCM_PTOBNAME (SCM_PTOBNUM (exp)),
- port);
+ SCM name = SCM_FILENAME (exp);
+ if (SCM_STRINGP (name) || SCM_SYMBOLP (name))
+ scm_display (name, port);
+ else
+ scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
scm_putc (' ', port);
fdes = (SCM_FSTREAM (exp))->fdes;
diff --git a/libguile/gc.c b/libguile/gc.c
index fa6474296..222553d3a 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1319,7 +1319,7 @@ gc_mark_nimp:
if (!(i < scm_numptob))
goto def;
if (SCM_PTAB_ENTRY(ptr))
- scm_gc_mark (SCM_PTAB_ENTRY(ptr)->file_name);
+ scm_gc_mark (SCM_FILENAME (ptr));
if (scm_ptobs[i].mark)
{
ptr = (scm_ptobs[i].mark) (ptr);
@@ -2272,7 +2272,9 @@ SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0,
void
scm_remember (SCM *ptr)
-{ /* empty */ }
+{
+ /* empty */
+}
/*
diff --git a/libguile/gh_data.c b/libguile/gh_data.c
index 0e359dc54..abcf27808 100644
--- a/libguile/gh_data.c
+++ b/libguile/gh_data.c
@@ -113,18 +113,16 @@ gh_set_substr (char *src, SCM dst, int start, int len)
unsigned long dst_len;
unsigned long effective_length;
- SCM_ASSERT (SCM_STRINGP (dst), dst, SCM_ARG3,
- "gh_set_substr");
+ SCM_ASSERT (SCM_STRINGP (dst), dst, SCM_ARG3, "gh_set_substr");
dst_ptr = SCM_STRING_CHARS (dst);
dst_len = SCM_STRING_LENGTH (dst);
SCM_ASSERT (len >= 0 && (unsigned) len <= dst_len,
dst, SCM_ARG4, "gh_set_substr");
- scm_protect_object (dst);
effective_length = ((unsigned) len < dst_len) ? len : dst_len;
memmove (dst_ptr + start, src, effective_length);
- scm_unprotect_object (dst);
+ scm_remember (&dst);
}
/* Return the symbol named SYMBOL_STR. */
@@ -539,19 +537,17 @@ gh_scm2newstr (SCM str, int *lenp)
SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG3, "gh_scm2newstr");
- /* protect str from GC while we copy off its data */
- scm_protect_object (str);
-
len = SCM_STRING_LENGTH (str);
ret_str = (char *) scm_must_malloc ((len + 1) * sizeof (char),
"gh_scm2newstr");
/* so we copy tmp_str to ret_str, which is what we will allocate */
memcpy (ret_str, SCM_ROCHARS (str), len); /* test ROCHARS here -twp */
+ /* from now on we don't mind if str gets GC collected. */
+ scm_remember (&str);
/* now make sure we null-terminate it */
ret_str[len] = '\0';
- scm_unprotect_object (str);
if (lenp != NULL)
{
@@ -575,12 +571,11 @@ gh_get_substr (SCM src, char *dst, int start, int len)
int src_len, effective_length;
SCM_ASSERT (SCM_STRINGP (src), src, SCM_ARG3, "gh_get_substr");
- scm_protect_object (src);
src_len = SCM_STRING_LENGTH (src);
effective_length = (len < src_len) ? len : src_len;
memcpy (dst + start, SCM_ROCHARS (src), effective_length * sizeof (char));
/* FIXME: must signal an error if len > src_len */
- scm_unprotect_object (src);
+ scm_remember (&src);
}
@@ -597,23 +592,19 @@ gh_symbol2newstr (SCM sym, int *lenp)
char *ret_str;
int len;
- SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG3,
- "gh_scm2newsymbol");
-
- /* protect str from GC while we copy off its data */
- scm_protect_object (sym);
+ SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG3, "gh_scm2newsymbol");
len = SCM_SYMBOL_LENGTH (sym);
ret_str = (char *) scm_must_malloc ((len + 1) * sizeof (char),
"gh_symbol2newstr");
- /* so we copy tmp_str to ret_str, which is what we will allocate */
+ /* so we copy sym to ret_str, which is what we will allocate */
memcpy (ret_str, SCM_SYMBOL_CHARS (sym), len);
+ /* from now on we don't mind if sym gets GC collected. */
+ scm_remember (&sym);
/* now make sure we null-terminate it */
ret_str[len] = '\0';
- scm_unprotect_object (sym);
-
if (lenp != NULL)
{
*lenp = len;
diff --git a/libguile/goops.c b/libguile/goops.c
index 83876e0d7..a470ab65a 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -2479,7 +2479,7 @@ make_struct_class (void *closure, SCM key, SCM data, SCM prev)
if (SCM_NFALSEP (SCM_STRUCT_TABLE_NAME (data)))
SCM_SET_STRUCT_TABLE_CLASS (data,
scm_make_extended_class
- (SCM_ROCHARS (SCM_STRUCT_TABLE_NAME (data))));
+ (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data))));
return SCM_UNSPECIFIED;
}
diff --git a/libguile/objects.c b/libguile/objects.c
index 700662ba2..68836dea5 100644
--- a/libguile/objects.c
+++ b/libguile/objects.c
@@ -191,7 +191,7 @@ scm_class_of (SCM x)
{
SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
SCM class = scm_make_extended_class (SCM_NFALSEP (name)
- ? SCM_ROCHARS (name)
+ ? SCM_SYMBOL_CHARS (name)
: 0);
SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
return class;
diff --git a/libguile/ports.c b/libguile/ports.c
index fe7ea9003..3f952a60a 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -1271,7 +1271,7 @@ SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0,
{
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1,port);
- return SCM_PTAB_ENTRY (port)->file_name;
+ return SCM_FILENAME (port);
}
#undef FUNC_NAME
@@ -1286,7 +1286,8 @@ SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0,
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1,port);
/* We allow the user to set the filename to whatever he likes. */
- return SCM_PTAB_ENTRY (port)->file_name = filename;
+ SCM_SET_FILENAME (port, filename);
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
diff --git a/libguile/ports.h b/libguile/ports.h
index b39c27fc1..0b12af557 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -169,6 +169,7 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */
#define SCM_STREAM(x) (SCM_PTAB_ENTRY(x)->stream)
#define SCM_SETSTREAM(x,s) (SCM_PTAB_ENTRY(x)->stream = (scm_bits_t) (s))
#define SCM_FILENAME(x) (SCM_PTAB_ENTRY(x)->file_name)
+#define SCM_SET_FILENAME(x, n) (SCM_PTAB_ENTRY(x)->file_name = (n))
#define SCM_LINUM(x) (SCM_PTAB_ENTRY(x)->line_number)
#define SCM_COL(x) (SCM_PTAB_ENTRY(x)->column_number)
#define SCM_REVEALED(x) (SCM_PTAB_ENTRY(x)->revealed)
diff --git a/libguile/print.c b/libguile/print.c
index 16ac4e4f4..a7408491e 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -439,10 +439,15 @@ taloop:
env = SCM_ENV (exp);
scm_puts ("#<procedure", port);
}
- if (SCM_ROSTRINGP (name))
+ if (SCM_SYMBOLP (name))
{
scm_putc (' ', port);
- scm_puts (SCM_ROCHARS (name), port);
+ scm_lfwrite (SCM_SYMBOL_CHARS (name), SCM_SYMBOL_LENGTH (name), port);
+ }
+ else if (SCM_STRINGP (name))
+ {
+ scm_putc (' ', port);
+ scm_lfwrite (SCM_ROCHARS (name), SCM_STRING_LENGTH (name), port);
}
if (!SCM_UNBNDP (code))
{
@@ -505,7 +510,6 @@ taloop:
len = SCM_SYMBOL_LENGTH (exp);
str = SCM_SYMBOL_CHARS (exp);
- scm_remember (&exp);
pos = 0;
weird = 0;
maybe_weird = 0;
@@ -568,6 +572,7 @@ taloop:
}
if (pos < end)
scm_lfwrite (str + pos, end - pos, port);
+ scm_remember (&exp);
if (weird)
scm_lfwrite ("}#", 2, port);
break;
@@ -664,7 +669,7 @@ taloop:
if (SCM_NFALSEP (name))
{
scm_putc (' ', port);
- scm_puts (SCM_ROCHARS (name), port);
+ scm_display (name, port);
}
}
scm_putc ('>', port);
@@ -972,6 +977,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
int fReturnString = 0;
int writingp;
char *start;
+ char *end;
char *p;
if (SCM_EQ_P (destination, SCM_BOOL_T))
@@ -995,13 +1001,16 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
SCM_VALIDATE_REST_ARGUMENT (args);
start = SCM_ROCHARS (message);
- for (p = start; *p != '\0'; ++p)
+ end = start + SCM_STRING_LENGTH (message);
+ for (p = start; p != end; ++p)
if (*p == '~')
{
- if (SCM_IMP (args) || SCM_NCONSP (args))
+ if (!SCM_CONSP (args))
+ continue;
+
+ if (++p == end)
continue;
- ++p;
if (*p == 'A' || *p == 'a')
writingp = 0;
else if (*p == 'S' || *p == 's')
diff --git a/libguile/symbols.h b/libguile/symbols.h
index e742f18b5..6160afc49 100644
--- a/libguile/symbols.h
+++ b/libguile/symbols.h
@@ -75,8 +75,6 @@ extern int scm_symhash_dim;
#define SCM_SYMBOL_HASH(X) (SCM_CELL_WORD_2 (X))
#define SCM_SET_SYMBOL_HASH(X, v) (SCM_SET_CELL_WORD_2 ((X), (v)))
-#define SCM_ROSTRINGP(x) (SCM_NIMP(x) && ((SCM_TYP7S(x)==scm_tc7_string) \
- || (SCM_TYP7(x) == scm_tc7_symbol)))
#define SCM_ROCHARS(x) ((SCM_TYP7 (x) == scm_tc7_substring) \
? (SCM_INUM (SCM_CADR (x)) + SCM_STRING_CHARS (SCM_CDDR (x))) \
: ((SCM_TYP7 (x) == scm_tc7_string) \
@@ -133,6 +131,8 @@ extern void scm_init_symbols (void);
#define SCM_SUBSTR_STR(x) (SCM_CDDR (x))
#define SCM_SUBSTR_OFFSET(x) (SCM_CADR (x))
#define SCM_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8)
+#define SCM_ROSTRINGP(x) (SCM_NIMP(x) && ((SCM_TYP7S(x)==scm_tc7_string) \
+ || (SCM_TYP7(x) == scm_tc7_symbol)))
#define SCM_ROLENGTH(x) SCM_LENGTH (x)
#define SCM_SUBSTRP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_substring))
#define SCM_COERCE_SUBSTR(x) SCM_STRING_COERCE_0TERMINATION_X (x)