diff options
author | Andy Wingo <wingo@pobox.com> | 2011-04-11 23:30:52 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-04-11 23:30:52 +0200 |
commit | 21c05db45b69f8a62b84c36abc86cb935fa967d7 (patch) | |
tree | 743df01da540e7fd628f54894e7d5fbe94b03996 /libguile | |
parent | 4db853d747ac115f799c93e2de93f5159ad84109 (diff) | |
parent | c89b45299329d034875429804f18768c1ea96713 (diff) | |
download | guile-21c05db45b69f8a62b84c36abc86cb935fa967d7.tar.gz |
Merge remote branch 'origin/stable-2.0'
Conflicts:
GUILE-VERSION
test-suite/tests/srfi-4.test
Diffstat (limited to 'libguile')
54 files changed, 1548 insertions, 824 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 20c179520..ac27eb8fb 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -460,7 +460,9 @@ version_info = @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGU libguile_@GUILE_EFFECTIVE_VERSION@_la_LDFLAGS = \ $(BDW_GC_LIBS) $(LIBFFI_LIBS) \ + $(CEIL_LIBM) \ $(FLOOR_LIBM) \ + $(FREXP_LIBM) \ $(GETADDRINFO_LIB) \ $(HOSTENT_LIB) \ $(INET_NTOP_LIB) \ @@ -468,12 +470,12 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_LDFLAGS = \ $(ISNAND_LIBM) \ $(ISNANF_LIBM) \ $(ISNANL_LIBM) \ + $(LDEXP_LIBM) \ $(LIBSOCKET) \ $(LOG1P_LIBM) \ $(LTLIBICONV) \ $(LTLIBINTL) \ $(LTLIBUNISTRING) \ - $(ROUND_LIBM) \ $(SERVENT_LIB) \ $(TRUNC_LIBM) \ -version-info $(version_info) \ diff --git a/libguile/array-handle.h b/libguile/array-handle.h index caf9cefbf..2e8af77b6 100644 --- a/libguile/array-handle.h +++ b/libguile/array-handle.h @@ -3,7 +3,8 @@ #ifndef SCM_ARRAY_HANDLE_H #define SCM_ARRAY_HANDLE_H -/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2004, 2006, + * 2008, 2009, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -64,25 +65,26 @@ typedef struct scm_t_array_dim ssize_t inc; } scm_t_array_dim; -typedef enum { - SCM_ARRAY_ELEMENT_TYPE_SCM = 0, /* SCM values */ - SCM_ARRAY_ELEMENT_TYPE_CHAR = 1, /* characters */ - SCM_ARRAY_ELEMENT_TYPE_BIT = 2, /* packed numeric values */ - SCM_ARRAY_ELEMENT_TYPE_VU8 = 3, - SCM_ARRAY_ELEMENT_TYPE_U8 = 4, - SCM_ARRAY_ELEMENT_TYPE_S8 = 5, - SCM_ARRAY_ELEMENT_TYPE_U16 = 6, - SCM_ARRAY_ELEMENT_TYPE_S16 = 7, - SCM_ARRAY_ELEMENT_TYPE_U32 = 8, - SCM_ARRAY_ELEMENT_TYPE_S32 = 9, - SCM_ARRAY_ELEMENT_TYPE_U64 = 10, - SCM_ARRAY_ELEMENT_TYPE_S64 = 11, - SCM_ARRAY_ELEMENT_TYPE_F32 = 12, - SCM_ARRAY_ELEMENT_TYPE_F64 = 13, - SCM_ARRAY_ELEMENT_TYPE_C32 = 14, - SCM_ARRAY_ELEMENT_TYPE_C64 = 15, - SCM_ARRAY_ELEMENT_TYPE_LAST = 15, -} scm_t_array_element_type; +typedef enum + { + SCM_ARRAY_ELEMENT_TYPE_SCM = 0, /* SCM values */ + SCM_ARRAY_ELEMENT_TYPE_CHAR = 1, /* characters */ + SCM_ARRAY_ELEMENT_TYPE_BIT = 2, /* packed numeric values */ + SCM_ARRAY_ELEMENT_TYPE_VU8 = 3, + SCM_ARRAY_ELEMENT_TYPE_U8 = 4, + SCM_ARRAY_ELEMENT_TYPE_S8 = 5, + SCM_ARRAY_ELEMENT_TYPE_U16 = 6, + SCM_ARRAY_ELEMENT_TYPE_S16 = 7, + SCM_ARRAY_ELEMENT_TYPE_U32 = 8, + SCM_ARRAY_ELEMENT_TYPE_S32 = 9, + SCM_ARRAY_ELEMENT_TYPE_U64 = 10, + SCM_ARRAY_ELEMENT_TYPE_S64 = 11, + SCM_ARRAY_ELEMENT_TYPE_F32 = 12, + SCM_ARRAY_ELEMENT_TYPE_F64 = 13, + SCM_ARRAY_ELEMENT_TYPE_C32 = 14, + SCM_ARRAY_ELEMENT_TYPE_C64 = 15, + SCM_ARRAY_ELEMENT_TYPE_LAST = 15 + } scm_t_array_element_type; SCM_INTERNAL SCM scm_i_array_element_types[]; diff --git a/libguile/arrays.c b/libguile/arrays.c index 89f5e9d09..6724d0071 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -860,7 +860,6 @@ SCM scm_i_read_array (SCM port, int c) { ssize_t rank; - int got_rank; char tag[80]; int tag_len; @@ -888,7 +887,6 @@ scm_i_read_array (SCM port, int c) return SCM_BOOL_F; } rank = 1; - got_rank = 1; tag[0] = 'f'; tag_len = 1; goto continue_reading_tag; diff --git a/libguile/backtrace.c b/libguile/backtrace.c index c7abe3173..db22c17e9 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -278,9 +278,7 @@ SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0, scm_print_state *pstate; /* Create a string port used for adaptation of printing parameters. */ - sport = scm_mkstrport (SCM_INUM0, - scm_make_string (scm_from_int (240), - SCM_UNDEFINED), + sport = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_OPN | SCM_WRTNG, FUNC_NAME); @@ -431,7 +429,7 @@ display_backtrace_body (struct display_backtrace_args *a) #define FUNC_NAME "display_backtrace_body" { int n_frames, beg, end, n, i, j; - int nfield, indent_p, indentation; + int nfield, indentation; SCM frame, sport, print_state; SCM last_file; scm_print_state *pstate; @@ -473,8 +471,7 @@ display_backtrace_body (struct display_backtrace_args *a) SCM_ASSERT (n > 0, a->depth, SCM_ARG4, s_display_backtrace); /* Create a string port used for adaptation of printing parameters. */ - sport = scm_mkstrport (SCM_INUM0, - scm_make_string (scm_from_int (240), SCM_UNDEFINED), + sport = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_OPN | SCM_WRTNG, FUNC_NAME); @@ -485,9 +482,6 @@ display_backtrace_body (struct display_backtrace_args *a) pstate->fancyp = 1; pstate->highlight_objects = a->highlight_objects; - /* First find out if it's reasonable to do indentation. */ - indent_p = 0; - /* Determine size of frame number field. */ j = end; for (i = 0; j > 0; ++i) j /= 10; diff --git a/libguile/bdw-gc.h b/libguile/bdw-gc.h index 3adf99e66..61c11eb94 100644 --- a/libguile/bdw-gc.h +++ b/libguile/bdw-gc.h @@ -1,7 +1,7 @@ #ifndef SCM_BDW_GC_H #define SCM_BDW_GC_H -/* Copyright (C) 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 2006, 2008, 2009, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -32,6 +32,11 @@ # define GC_THREADS 1 # define GC_REDIRECT_TO_LOCAL 1 +/* Don't #define pthread routines to their GC_pthread counterparts. + Instead we will be careful inside Guile to use the GC_pthread + routines. */ +# define GC_NO_THREAD_REDIRECTS 1 + #endif #include <gc/gc.h> diff --git a/libguile/continuations.c b/libguile/continuations.c index dc6850e05..7d56c2a59 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -460,6 +460,45 @@ scm_i_with_continuation_barrier (scm_t_catch_body body, return result; } + + +static int +should_print_backtrace (SCM tag, SCM stack) +{ + return SCM_BACKTRACE_P + && scm_is_true (stack) + && scm_initialized_p + /* It's generally not useful to print backtraces for errors reading + or expanding code in these fallback catch statements. */ + && !scm_is_eq (tag, scm_from_latin1_symbol ("read-error")) + && !scm_is_eq (tag, scm_from_latin1_symbol ("syntax-error")); +} + +static void +print_exception_and_backtrace (SCM port, SCM tag, SCM args) +{ + SCM stack, frame; + + /* We get here via a throw to a catch-all. In that case there is the + throw frame active, and this catch closure, so narrow by two + frames. */ + stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2))); + frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F; + + if (should_print_backtrace (tag, stack)) + { + scm_puts ("Backtrace:\n", port); + scm_display_backtrace_with_highlights (stack, port, + SCM_BOOL_F, SCM_BOOL_F, + SCM_EOL); + scm_newline (port); + } + + scm_print_exception (port, frame, tag, args); +} + + + struct c_data { void *(*func) (void *); void *data; @@ -477,11 +516,27 @@ c_body (void *d) static SCM c_handler (void *d, SCM tag, SCM args) { - struct c_data *data = (struct c_data *)d; + struct c_data *data; + + /* If TAG is `quit', exit() the process. */ + if (scm_is_eq (tag, scm_from_latin1_symbol ("quit"))) + exit (scm_exit_status (args)); + + data = (struct c_data *)d; data->result = NULL; return SCM_UNSPECIFIED; } +static SCM +pre_unwind_handler (void *error_port, SCM tag, SCM args) +{ + /* Print the exception unless TAG is `quit'. */ + if (!scm_is_eq (tag, scm_from_latin1_symbol ("quit"))) + print_exception_and_backtrace (PTR2SCM (error_port), tag, args); + + return SCM_UNSPECIFIED; +} + void * scm_c_with_continuation_barrier (void *(*func) (void *), void *data) { @@ -490,7 +545,8 @@ scm_c_with_continuation_barrier (void *(*func) (void *), void *data) c_data.data = data; scm_i_with_continuation_barrier (c_body, &c_data, c_handler, &c_data, - scm_handle_by_message_noexit, NULL); + pre_unwind_handler, + SCM2PTR (scm_current_error_port ())); return c_data.result; } @@ -508,6 +564,10 @@ scm_body (void *d) static SCM scm_handler (void *d, SCM tag, SCM args) { + /* Print a message. Note that if TAG is `quit', this will exit() the + process. */ + scm_handle_by_message_noexit (NULL, tag, args); + return SCM_BOOL_F; } @@ -529,7 +589,8 @@ SCM_DEFINE (scm_with_continuation_barrier, "with-continuation-barrier", 1,0,0, scm_data.proc = proc; return scm_i_with_continuation_barrier (scm_body, &scm_data, scm_handler, &scm_data, - scm_handle_by_message_noexit, NULL); + pre_unwind_handler, + SCM2PTR (scm_current_error_port ())); } #undef FUNC_NAME diff --git a/libguile/control.c b/libguile/control.c index b6a558769..dc3fed250 100644 --- a/libguile/control.c +++ b/libguile/control.c @@ -55,18 +55,18 @@ scm_c_make_prompt (SCM k, SCM *fp, SCM *sp, scm_t_uint8 *abort_ip, /* Only to be called if the SCM_PROMPT_SETJMP returns 1 */ SCM -scm_i_prompt_pop_abort_args_x (SCM prompt) +scm_i_prompt_pop_abort_args_x (SCM vm) { size_t i, n; SCM vals = SCM_EOL; - n = scm_to_size_t (SCM_PROMPT_REGISTERS (prompt)->sp[0]); + n = scm_to_size_t (SCM_VM_DATA (vm)->sp[0]); for (i = 0; i < n; i++) - vals = scm_cons (SCM_PROMPT_REGISTERS (prompt)->sp[-(i + 1)], vals); + vals = scm_cons (SCM_VM_DATA (vm)->sp[-(i + 1)], vals); /* The abort did reset the VM's registers, but then these values were pushed on; so we need to pop them ourselves. */ - SCM_VM_DATA (scm_the_vm ())->sp -= n + 1; + SCM_VM_DATA (vm)->sp -= n + 1; /* FIXME NULLSTACK */ return vals; diff --git a/libguile/control.h b/libguile/control.h index bbc4c2099..2167ffa08 100644 --- a/libguile/control.h +++ b/libguile/control.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2010 Free Software Foundation, Inc. +/* Copyright (C) 2010, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -46,7 +46,7 @@ SCM_INTERNAL SCM scm_c_make_prompt (SCM k, SCM *fp, SCM *sp, scm_t_uint8 escape_only_p, scm_t_int64 vm_cookie, SCM winds); -SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (SCM prompt); +SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (SCM vm); SCM_INTERNAL void scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv, scm_t_int64 cookie) SCM_NORETURN; diff --git a/libguile/deprecated.c b/libguile/deprecated.c index fd23e2dc9..4d6027c35 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -2281,7 +2281,7 @@ scm_allocate_string (size_t len) { scm_c_issue_deprecation_warning ("`scm_allocate_string' is deprecated. Use scm_c_make_string instead."); - return scm_i_make_string (len, NULL); + return scm_i_make_string (len, NULL, 0); } SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, diff --git a/libguile/dynl.c b/libguile/dynl.c index 2484ddaa0..a2ae6e267 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -115,9 +115,8 @@ sysdep_dynl_value (const char *symb, void *handle, const char *subr) fptr = lt_dlsym ((lt_dlhandle) handle, symb); if (!fptr) - { - scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL); - } + scm_misc_error (subr, "Symbol not found: ~a", + scm_list_1 (scm_from_locale_string (symb))); return fptr; } diff --git a/libguile/eval.c b/libguile/eval.c index 6f2020ebc..164aadd70 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -424,7 +424,7 @@ eval (SCM x, SCM env) { /* The prompt exited nonlocally. */ proc = handler; - args = scm_i_prompt_pop_abort_args_x (prompt); + args = scm_i_prompt_pop_abort_args_x (scm_the_vm ()); goto apply_proc; } @@ -477,6 +477,21 @@ scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4) } SCM +scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5) +{ + SCM args[] = { arg1, arg2, arg3, arg4, arg5 }; + return scm_c_vm_run (scm_the_vm (), proc, args, 5); +} + +SCM +scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5, + SCM arg6) +{ + SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6 }; + return scm_c_vm_run (scm_the_vm (), proc, args, 6); +} + +SCM scm_call_n (SCM proc, SCM *argv, size_t nargs) { return scm_c_vm_run (scm_the_vm (), proc, argv, nargs); @@ -543,11 +558,7 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0, SCM *lloc; SCM_VALIDATE_NONEMPTYLIST (1, lst); lloc = &lst; - while (!scm_is_null (SCM_CDR (*lloc))) /* Perhaps should be - SCM_NULL_OR_NIL_P, but not - needed in 99.99% of cases, - and it could seriously hurt - performance. - Neil */ + while (!scm_is_null (SCM_CDR (*lloc))) lloc = SCM_CDRLOC (*lloc); SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME); *lloc = SCM_CAR (*lloc); diff --git a/libguile/eval.h b/libguile/eval.h index 969cce129..f193ad64e 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -3,7 +3,7 @@ #ifndef SCM_EVAL_H #define SCM_EVAL_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010 +/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -68,6 +68,10 @@ SCM_API SCM scm_call_1 (SCM proc, SCM arg1); SCM_API SCM scm_call_2 (SCM proc, SCM arg1, SCM arg2); SCM_API SCM scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3); SCM_API SCM scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4); +SCM_API SCM scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, + SCM arg5); +SCM_API SCM scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, + SCM arg5, SCM arg6); SCM_API SCM scm_call_n (SCM proc, SCM *argv, size_t nargs); SCM_API SCM scm_apply_0 (SCM proc, SCM args); SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args); diff --git a/libguile/filesys.c b/libguile/filesys.c index 68d90d926..96752bcd7 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -845,7 +845,6 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0, { struct dirent_or_dirent64 de; /* just for sizeof */ DIR *ds = (DIR *) SCM_SMOB_DATA_1 (port); - size_t namlen; #ifdef NAME_MAX char buf [SCM_MAX (sizeof (de), sizeof (de) - sizeof (de.d_name) + NAME_MAX + 1)]; @@ -865,8 +864,6 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0, if (! rdent) return SCM_EOF_VAL; - namlen = NAMLEN (rdent); - return (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent)) : SCM_EOF_VAL); } diff --git a/libguile/foreign.c b/libguile/foreign.c index 6f008e761..ae9e27a8d 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -177,6 +177,34 @@ SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_pointer_to_scm, "pointer->scm", 1, 0, 0, + (SCM pointer), + "Unsafely cast @var{pointer} to a Scheme object.\n" + "Cross your fingers!") +#define FUNC_NAME s_scm_pointer_to_scm +{ + SCM_VALIDATE_POINTER (1, pointer); + + return SCM_PACK ((scm_t_bits) SCM_POINTER_VALUE (pointer)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_scm_to_pointer, "scm->pointer", 1, 0, 0, + (SCM scm), + "Return a foreign pointer object with the @code{object-address}\n" + "of @var{scm}.") +#define FUNC_NAME s_scm_scm_to_pointer +{ + SCM ret; + + ret = scm_from_pointer ((void*) SCM_UNPACK (scm), NULL); + if (SCM_NIMP (ret)) + register_weak_reference (ret, scm); + + return ret; +} +#undef FUNC_NAME + SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0, (SCM pointer, SCM len, SCM offset, SCM uvec_type), "Return a bytevector aliasing the @var{len} bytes pointed\n" @@ -327,13 +355,13 @@ SCM_DEFINE (scm_dereference_pointer, "dereference-pointer", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 0, 0, - (SCM string), +SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 1, 0, + (SCM string, SCM encoding), "Return a foreign pointer to a nul-terminated copy of\n" - "@var{string} in the current locale encoding. The C\n" - "string is freed when the returned foreign pointer\n" - "becomes unreachable.\n\n" - "This is the Scheme equivalent of @code{scm_to_locale_string}.") + "@var{string} in the given @var{encoding}, defaulting to\n" + "the current locale encoding. The C string is freed when\n" + "the returned foreign pointer becomes unreachable.\n\n" + "This is the Scheme equivalent of @code{scm_to_stringn}.") #define FUNC_NAME s_scm_string_to_pointer { SCM_VALIDATE_STRING (1, string); @@ -341,21 +369,72 @@ SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 0, 0, /* XXX: Finalizers slow down libgc; they could be avoided if `scm_to_string' & co. were able to use libgc-allocated memory. */ - return scm_from_pointer (scm_to_locale_string (string), free); + if (SCM_UNBNDP (encoding)) + return scm_from_pointer (scm_to_locale_string (string), free); + else + { + char *enc; + SCM ret; + + SCM_VALIDATE_STRING (2, encoding); + + enc = scm_to_locale_string (encoding); + scm_dynwind_begin (0); + scm_dynwind_free (enc); + + ret = scm_from_pointer + (scm_to_stringn (string, NULL, enc, + scm_i_get_conversion_strategy (SCM_BOOL_F)), + free); + + scm_dynwind_end (); + + return ret; + } } #undef FUNC_NAME -SCM_DEFINE (scm_pointer_to_string, "pointer->string", 1, 0, 0, - (SCM pointer), - "Return the string representing the C nul-terminated string\n" - "pointed to by @var{pointer}. The C string is assumed to be\n" - "in the current locale encoding.\n\n" - "This is the Scheme equivalent of @code{scm_from_locale_string}.") +SCM_DEFINE (scm_pointer_to_string, "pointer->string", 1, 2, 0, + (SCM pointer, SCM length, SCM encoding), + "Return the string representing the C string pointed to by\n" + "@var{pointer}. If @var{length} is omitted or @code{-1}, the\n" + "string is assumed to be nul-terminated. Otherwise\n" + "@var{length} is the number of bytes in memory pointed to by\n" + "@var{pointer}. The C string is assumed to be in the given\n" + "@var{encoding}, defaulting to the current locale encoding.\n\n" + "This is the Scheme equivalent of @code{scm_from_stringn}.") #define FUNC_NAME s_scm_pointer_to_string { + size_t len; + SCM_VALIDATE_POINTER (1, pointer); - return scm_from_locale_string (SCM_POINTER_VALUE (pointer)); + if (SCM_UNBNDP (length) + || scm_is_true (scm_eqv_p (length, scm_from_int (-1)))) + len = (size_t)-1; + else + len = scm_to_size_t (length); + + if (SCM_UNBNDP (encoding)) + return scm_from_locale_stringn (SCM_POINTER_VALUE (pointer), len); + else + { + char *enc; + SCM ret; + + SCM_VALIDATE_STRING (3, encoding); + + enc = scm_to_locale_string (encoding); + scm_dynwind_begin (0); + scm_dynwind_free (enc); + + ret = scm_from_stringn (SCM_POINTER_VALUE (pointer), len, enc, + scm_i_get_conversion_strategy (SCM_BOOL_F)); + + scm_dynwind_end (); + + return ret; + } } #undef FUNC_NAME @@ -402,8 +481,24 @@ SCM_DEFINE (scm_alignof, "alignof", 1, 0, 0, (SCM type), /* a pointer */ return scm_from_size_t (alignof (void*)); else if (scm_is_pair (type)) - /* a struct, yo */ - return scm_alignof (scm_car (type)); + { + /* TYPE is a structure. Section 3-3 of the i386, x86_64, PowerPC, + and SPARC P.S. of the System V ABI all say: "Aggregates + (structures and arrays) and unions assume the alignment of + their most strictly aligned component." */ + size_t max; + + for (max = 0; scm_is_pair (type); type = SCM_CDR (type)) + { + size_t align; + + align = scm_to_size_t (scm_alignof (SCM_CAR (type))); + if (align > max) + max = align; + } + + return scm_from_size_t (max); + } else scm_wrong_type_arg (FUNC_NAME, 1, type); } @@ -861,6 +956,9 @@ unpack (const ffi_type *type, void *loc, SCM x) SCM_VALIDATE_POINTER (1, x); *(void **) loc = SCM_POINTER_VALUE (x); break; + case FFI_TYPE_VOID: + /* Do nothing. */ + break; default: abort (); } diff --git a/libguile/foreign.h b/libguile/foreign.h index b29001962..6c6f37306 100644 --- a/libguile/foreign.h +++ b/libguile/foreign.h @@ -72,8 +72,8 @@ SCM_INTERNAL void scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate); SCM_INTERNAL SCM scm_dereference_pointer (SCM pointer); -SCM_INTERNAL SCM scm_string_to_pointer (SCM string); -SCM_INTERNAL SCM scm_pointer_to_string (SCM pointer); +SCM_INTERNAL SCM scm_string_to_pointer (SCM string, SCM encoding); +SCM_INTERNAL SCM scm_pointer_to_string (SCM pointer, SCM length, SCM encoding); diff --git a/libguile/frames.c b/libguile/frames.c index bc1bb82a8..62ba23fff 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -124,7 +124,7 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0, p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame)); while (p <= sp) { - if (p + 1 < sp && p[1] == (SCM)0) + if (p[0] == (SCM)0) /* skip over not-yet-active frame */ p += 3; else @@ -154,7 +154,7 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0, p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame)); while (p <= sp) { - if (p + 1 < sp && p[1] == (SCM)0) + if (p[0] == (SCM)0) /* skip over not-yet-active frame */ p += 3; else if (n == i) @@ -186,7 +186,7 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0, p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame)); while (p <= sp) { - if (p + 1 < sp && p[1] == (SCM)0) + if (p[0] == (SCM)0) /* skip over not-yet-active frame */ p += 3; else if (n == i) diff --git a/libguile/gc.c b/libguile/gc.c index 91250ba57..8816a61a6 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -69,10 +69,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include <unistd.h> #endif -/* Lock this mutex before doing lazy sweeping. - */ -scm_i_pthread_mutex_t scm_i_sweep_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; - /* Set this to != 0 if every cell that is accessed shall be checked: */ int scm_debug_cell_accesses_p = 0; @@ -206,23 +202,13 @@ unsigned long scm_gc_ports_collected = 0; static unsigned long protected_obj_count = 0; -SCM_SYMBOL (sym_cells_allocated, "cells-allocated"); +SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken"); SCM_SYMBOL (sym_heap_size, "heap-size"); SCM_SYMBOL (sym_heap_free_size, "heap-free-size"); SCM_SYMBOL (sym_heap_total_allocated, "heap-total-allocated"); -SCM_SYMBOL (sym_mallocated, "bytes-malloced"); -SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold"); -SCM_SYMBOL (sym_heap_segments, "cell-heap-segments"); -SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken"); -SCM_SYMBOL (sym_gc_mark_time_taken, "gc-mark-time-taken"); -SCM_SYMBOL (sym_times, "gc-times"); -SCM_SYMBOL (sym_cells_marked, "cells-marked"); -SCM_SYMBOL (sym_cells_marked_conservatively, "cells-marked-conservatively"); -SCM_SYMBOL (sym_cells_swept, "cells-swept"); -SCM_SYMBOL (sym_malloc_yield, "malloc-yield"); -SCM_SYMBOL (sym_cell_yield, "cell-yield"); +SCM_SYMBOL (sym_heap_allocated_since_gc, "heap-allocated-since-gc"); SCM_SYMBOL (sym_protected_objects, "protected-objects"); -SCM_SYMBOL (sym_total_cells_allocated, "total-cells-allocated"); +SCM_SYMBOL (sym_times, "gc-times"); /* Number of calls to SCM_NEWCELL since startup. */ @@ -287,33 +273,14 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, total_bytes = GC_get_total_bytes (); gc_times = GC_gc_no; - /* njrev: can any of these scm_cons's or scm_list_n signal a memory - error? If so we need a frame here. */ answer = scm_list_n (scm_cons (sym_gc_time_taken, SCM_INUM0), -#if 0 - scm_cons (sym_cells_allocated, - scm_from_ulong (local_scm_cells_allocated)), - scm_cons (sym_mallocated, - scm_from_ulong (local_scm_mallocated)), - scm_cons (sym_mtrigger, - scm_from_ulong (local_scm_mtrigger)), - scm_cons (sym_gc_mark_time_taken, - scm_from_ulong (local_scm_gc_mark_time_taken)), - scm_cons (sym_cells_marked, - scm_from_double (local_scm_gc_cells_marked)), - scm_cons (sym_cells_swept, - scm_from_double (local_scm_gc_cells_swept)), - scm_cons (sym_malloc_yield, - scm_from_long (local_scm_gc_malloc_yield_percentage)), - scm_cons (sym_cell_yield, - scm_from_long (local_scm_gc_cell_yield_percentage)), - scm_cons (sym_heap_segments, heap_segs), -#endif scm_cons (sym_heap_size, scm_from_size_t (heap_size)), scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)), scm_cons (sym_heap_total_allocated, scm_from_size_t (total_bytes)), + scm_cons (sym_heap_allocated_since_gc, + scm_from_size_t (bytes_since_gc)), scm_cons (sym_protected_objects, scm_from_ulong (protected_obj_count)), scm_cons (sym_times, scm_from_size_t (gc_times)), @@ -377,17 +344,7 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0, "no longer accessible.") #define FUNC_NAME s_scm_gc { - scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex); scm_i_gc ("call"); - /* njrev: It looks as though other places, e.g. scm_realloc, - can call scm_i_gc without acquiring the sweep mutex. Does this - matter? Also scm_i_gc (or its descendants) touch the - scm_sys_protects, which are protected in some cases - (e.g. scm_permobjs above in scm_gc_stats) by a critical section, - not by the sweep mutex. Shouldn't all the GC-relevant objects be - protected in the same way? */ - scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex); - scm_c_hook_run (&scm_after_gc_c_hook, 0); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -587,6 +544,23 @@ scm_gc_unregister_roots (SCM *b, unsigned long n) scm_gc_unregister_root (p); } +static void +scm_c_register_gc_callback (void *key, void (*func) (void *, void *), + void *data) +{ + if (!key) + key = GC_MALLOC_ATOMIC (sizeof (void*)); + + GC_REGISTER_FINALIZER_NO_ORDER (key, func, data, NULL, NULL); +} + +static void +system_gc_callback (void *key, void *data) +{ + scm_c_register_gc_callback (key, system_gc_callback, data); + scm_c_hook_run (&scm_after_gc_c_hook, NULL); +} + @@ -642,6 +616,8 @@ scm_storage_prehistory () scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL); scm_c_hook_init (&scm_after_sweep_c_hook, 0, SCM_C_HOOK_NORMAL); scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL); + + scm_c_register_gc_callback (NULL, system_gc_callback, NULL); } scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; diff --git a/libguile/gdbint.c b/libguile/gdbint.c index 7cc9535d7..77fdbd17a 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -1,5 +1,5 @@ /* GDB interface for Guile - * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,2009 + * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,2009,2011 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -248,15 +248,13 @@ scm_init_gdbint () SCM port; scm_print_carefully_p = 0; - - port = scm_mkstrport (SCM_INUM0, - scm_c_make_string (0, SCM_UNDEFINED), + + port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_OPN | SCM_WRTNG, s); gdb_output_port = scm_permanent_object (port); - - port = scm_mkstrport (SCM_INUM0, - scm_c_make_string (0, SCM_UNDEFINED), + + port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_OPN | SCM_RDNG | SCM_WRTNG, s); gdb_input_port = scm_permanent_object (port); diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index 02633563d..5834346c7 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -318,6 +318,24 @@ main (int argc, char *argv[]) pf ("#define SCM_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER %d /* 0 or 1 */\n", SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER); +#ifdef HAVE_GC_PTHREAD_CANCEL + pf ("#define SCM_HAVE_GC_PTHREAD_CANCEL 1 /* 0 or 1 */\n"); +#else + pf ("#define SCM_HAVE_GC_PTHREAD_CANCEL 0 /* 0 or 1 */\n"); +#endif + +#ifdef HAVE_GC_PTHREAD_EXIT + pf ("#define SCM_HAVE_GC_PTHREAD_EXIT 1 /* 0 or 1 */\n"); +#else + pf ("#define SCM_HAVE_GC_PTHREAD_EXIT 0 /* 0 or 1 */\n"); +#endif + +#ifdef HAVE_GC_PTHREAD_SIGMASK + pf ("#define SCM_HAVE_GC_PTHREAD_SIGMASK 1 /* 0 or 1 */\n"); +#else + pf ("#define SCM_HAVE_GC_PTHREAD_SIGMASK 0 /* 0 or 1 */\n"); +#endif + pf ("\n\n/*** File system access ***/\n"); pf ("/* Define to 1 if `struct dirent64' is available. */\n"); diff --git a/libguile/goops.c b/libguile/goops.c index c597044f5..f6102085f 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -670,7 +670,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, SCM_MISC_ERROR ("class object doesn't have enough fields: ~S", scm_list_1 (nfields)); - layout = scm_i_make_string (n, &s); + layout = scm_i_make_string (n, &s, 0); i = 0; while (scm_is_pair (getters_n_setters)) { diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in index 043b3ed0d..c73e8ce1e 100644 --- a/libguile/guile-snarf.in +++ b/libguile/guile-snarf.in @@ -51,7 +51,20 @@ modern_snarf () # writes stdout ## empty file. echo "/* cpp arguments: $@ */" ; ${cpp} -DSCM_MAGIC_SNARF_INITS -DSCM_MAGIC_SNARFER "$@" > ${temp} && cpp_ok_p=true - grep "^ *\^ *\^" ${temp} | sed -e "s/ *\^ *\^//g" -e "s/\^ *: *\^/;/g" + sed -ne 's/ *\^ *: *\^/\ +/ +h +s/\n.*// +t x +d +: x +s/.*\^ *\^ *\(.*\)/\1;/ +t y +d +: y +p +x +D' ${temp} } ## main diff --git a/libguile/hashtab.c b/libguile/hashtab.c index f3887c213..a76c03812 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -33,6 +33,7 @@ #include "libguile/root.h" #include "libguile/vectors.h" #include "libguile/ports.h" +#include "libguile/bdw-gc.h" #include "libguile/validate.h" #include "libguile/hashtab.h" @@ -120,6 +121,26 @@ scm_fixup_weak_alist (SCM alist, size_t *removed_items) return result; } +static void +vacuum_weak_hash_table (SCM table) +{ + SCM buckets = SCM_HASHTABLE_VECTOR (table); + unsigned long k = SCM_SIMPLE_VECTOR_LENGTH (buckets); + size_t len = SCM_HASHTABLE_N_ITEMS (table); + + while (k--) + { + size_t removed; + SCM alist = SCM_SIMPLE_VECTOR_REF (buckets, k); + alist = scm_fixup_weak_alist (alist, &removed); + assert (removed <= len); + len -= removed; + SCM_SIMPLE_VECTOR_SET (buckets, k, alist); + } + + SCM_SET_HASHTABLE_N_ITEMS (table, len); +} + /* Packed arguments for `do_weak_bucket_fixup'. */ struct t_fixup_args @@ -397,6 +418,34 @@ SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0, } #undef FUNC_NAME +static void +weak_gc_callback (void *ptr, void *data) +{ + void **weak = ptr; + void *val = *weak; + + if (val) + { + void (*callback) (SCM) = data; + + GC_REGISTER_FINALIZER_NO_ORDER (ptr, weak_gc_callback, data, NULL, NULL); + + callback (PTR2SCM (val)); + } +} + +static void +scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM)) +{ + void **weak = GC_MALLOC_ATOMIC (sizeof (void**)); + + *weak = SCM2PTR (obj); + GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj)); + + GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_callback, (void*)callback, + NULL, NULL); +} + SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0, (SCM n), "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n" @@ -407,11 +456,17 @@ SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0, "would modify regular hash tables. (@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_weak_key_hash_table { + SCM ret; + if (SCM_UNBNDP (n)) - return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME); + ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME); else - return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, - scm_to_ulong (n), FUNC_NAME); + ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR, + scm_to_ulong (n), FUNC_NAME); + + scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table); + + return ret; } #undef FUNC_NAME @@ -422,13 +477,17 @@ SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, "(@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_weak_value_hash_table { + SCM ret; + if (SCM_UNBNDP (n)) - return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME); + ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME); else - { - return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, - scm_to_ulong (n), FUNC_NAME); - } + ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR, + scm_to_ulong (n), FUNC_NAME); + + scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table); + + return ret; } #undef FUNC_NAME @@ -439,16 +498,18 @@ SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0 "buckets. (@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_doubly_weak_hash_table { + SCM ret; + if (SCM_UNBNDP (n)) - return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR, - 0, - FUNC_NAME); + ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR, + 0, FUNC_NAME); else - { - return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR, - scm_to_ulong (n), - FUNC_NAME); - } + ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR, + scm_to_ulong (n), FUNC_NAME); + + scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table); + + return ret; } #undef FUNC_NAME @@ -651,12 +712,9 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, } SCM_SETCDR (new_bucket, SCM_SIMPLE_VECTOR_REF (buckets, k)); SCM_SIMPLE_VECTOR_SET (buckets, k, new_bucket); - /* Update element count and maybe rehash the table. The - table might have too few entries here since weak hash - tables used with the hashx_* functions can not be - rehashed after GC. - */ SCM_HASHTABLE_INCREMENT (table); + + /* Maybe rehash the table. */ if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table) || SCM_HASHTABLE_N_ITEMS (table) > SCM_HASHTABLE_UPPER (table)) scm_i_rehash (table, hash_fn, closure, FUNC_NAME); diff --git a/libguile/i18n.c b/libguile/i18n.c index 14dc9b985..fc651fd7e 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -766,16 +766,10 @@ compare_u32_strings (SCM s1, SCM s2, SCM locale, const char *func_name) static const char * locale_language () { - /* FIXME: If the locale has been set with 'uselocale', - libunistring's uc_locale_language will return the incorrect - language: it will return the language appropriate for the global - (non-thread-specific) locale. - - There appears to be no portable way to extract the language from - the thread-specific locale_t. There is no LANGUAGE capability in - nl_langinfo or nl_langinfo_l. - - Thus, uc_locale_language needs to be fixed upstream. */ + /* Note: If the locale has been set with 'uselocale', uc_locale_language + from libunistring versions 0.9.1 and older will return the incorrect + (non-thread-specific) locale. This is fixed in versions 0.9.2 and + newer. */ return uc_locale_language (); } @@ -1113,23 +1107,19 @@ chr_to_case (SCM chr, scm_t_locale c_locale, #define FUNC_NAME func_name { int ret; - scm_t_wchar *buf; + scm_t_uint32 c; scm_t_uint32 *convbuf; size_t convlen; - SCM str, convchar; + SCM convchar; - str = scm_i_make_wide_string (1, &buf); - buf[0] = SCM_CHAR (chr); + c = SCM_CHAR (chr); if (c_locale != NULL) RUN_IN_LOCALE_SECTION (c_locale, ret = - u32_locale_tocase ((scm_t_uint32 *) buf, 1, - &convbuf, - &convlen, func)); + u32_locale_tocase (&c, 1, &convbuf, &convlen, func)); else ret = - u32_locale_tocase ((scm_t_uint32 *) buf, 1, &convbuf, - &convlen, func); + u32_locale_tocase (&c, 1, &convbuf, &convlen, func); if (SCM_UNLIKELY (ret != 0)) { @@ -1256,7 +1246,7 @@ str_to_case (SCM str, scm_t_locale c_locale, return NULL; } - convstr = scm_i_make_wide_string (convlen, &c_buf); + convstr = scm_i_make_wide_string (convlen, &c_buf, 0); memcpy (c_buf, c_convstr, convlen * sizeof (scm_t_wchar)); free (c_convstr); @@ -1564,11 +1554,14 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, { char *p; - /* In this cases, the result is to be interpreted as a list of - numbers. If the last item is `CHARS_MAX', it has the special - meaning "no more grouping". */ + /* In this cases, the result is to be interpreted as a list + of numbers. If the last item is `CHAR_MAX' or a negative + number, it has the special meaning "no more grouping" + (negative numbers aren't specified in POSIX but can be + used by glibc; see + <http://lists.gnu.org/archive/html/bug-guile/2011-02/msg00159.html>). */ result = SCM_EOL; - for (p = c_result; (*p != '\0') && (*p != CHAR_MAX); p++) + for (p = c_result; (*p > 0) && (*p != CHAR_MAX); p++) result = scm_cons (SCM_I_MAKINUM ((int) *p), result); { @@ -1576,7 +1569,7 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, result = scm_reverse_x (result, SCM_EOL); - if (*p != CHAR_MAX) + if (*p == 0) { /* Cyclic grouping information. */ if (last_pair != SCM_EOL) diff --git a/libguile/init.c b/libguile/init.c index 9b8c4d086..8b3b8cd33 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -157,7 +157,6 @@ typedef struct { int fdes; char *mode; - char *name; } stream_body_data; /* proc to be called in scope of exception handler stream_handler. */ @@ -165,8 +164,7 @@ static SCM stream_body (void *data) { stream_body_data *body_data = (stream_body_data *) data; - SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode, - scm_from_locale_string (body_data->name)); + SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode, SCM_BOOL_F); SCM_REVEALED (port) = 1; return port; @@ -182,21 +180,19 @@ stream_handler (void *data SCM_UNUSED, } /* Convert a file descriptor to a port, using scm_fdes_to_port. - - NAME is a C string, not a Guile string - set the revealed count for FILE's file descriptor to 1, so that fdes won't be closed when the port object is GC'd. - catch exceptions: allow Guile to be able to start up even if it has been handed bogus stdin/stdout/stderr. replace the bad ports with void ports. */ static SCM -scm_standard_stream_to_port (int fdes, char *mode, char *name) +scm_standard_stream_to_port (int fdes, char *mode) { SCM port; stream_body_data body_data; body_data.fdes = fdes; body_data.mode = mode; - body_data.name = name; port = scm_internal_catch (SCM_BOOL_T, stream_body, &body_data, stream_handler, NULL); if (scm_is_false (port)) @@ -223,17 +219,11 @@ scm_init_standard_ports () block buffering for higher performance. */ scm_set_current_input_port - (scm_standard_stream_to_port (0, - isatty (0) ? "r0" : "r", - "standard input")); + (scm_standard_stream_to_port (0, isatty (0) ? "r0" : "r")); scm_set_current_output_port - (scm_standard_stream_to_port (1, - isatty (1) ? "w0" : "w", - "standard output")); + (scm_standard_stream_to_port (1, isatty (1) ? "w0" : "w")); scm_set_current_error_port - (scm_standard_stream_to_port (2, - isatty (2) ? "w0" : "w", - "standard error")); + (scm_standard_stream_to_port (2, isatty (2) ? "w0" : "w")); } @@ -386,17 +376,11 @@ cleanup_for_exit () } void -scm_i_init_guile (SCM_STACKITEM *base) +scm_i_init_guile (void *base) { if (scm_initialized_p) return; - if (base == NULL) - { - fprintf (stderr, "cannot determine stack base!\n"); - abort (); - } - if (sizeof (mpz_t) > (3 * sizeof (scm_t_bits))) { fprintf (stderr, diff --git a/libguile/init.h b/libguile/init.h index 7cfae76d5..bc6cddf93 100644 --- a/libguile/init.h +++ b/libguile/init.h @@ -3,7 +3,7 @@ #ifndef SCM_INIT_H #define SCM_INIT_H -/* Copyright (C) 1995,1996,1997,2000, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,2000, 2006, 2008, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -38,7 +38,7 @@ SCM_API void scm_boot_guile (int argc, char **argv, char **argv), void *closure); -SCM_INTERNAL void scm_i_init_guile (SCM_STACKITEM *base); +SCM_INTERNAL void scm_i_init_guile (void *base); SCM_API void scm_load_startup_files (void); diff --git a/libguile/modules.c b/libguile/modules.c index 40f9c84b1..e06082186 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -56,6 +56,9 @@ static SCM module_public_interface_var; static SCM module_export_x_var; static SCM default_duplicate_binding_procedures_var; +/* The #:ensure keyword. */ +static SCM k_ensure; + static SCM unbound_variable (const char *func, SCM sym) { @@ -752,6 +755,124 @@ scm_lookup (SCM sym) } SCM +scm_public_variable (SCM module_name, SCM name) +{ + SCM mod, iface; + + mod = scm_call_3 (scm_variable_ref (resolve_module_var), module_name, + k_ensure, SCM_BOOL_F); + + if (scm_is_false (mod)) + scm_misc_error ("public-lookup", "Module named ~s does not exist", + scm_list_1 (module_name)); + + iface = scm_module_public_interface (mod); + + if (scm_is_false (iface)) + scm_misc_error ("public-lookup", "Module ~s has no public interface", + scm_list_1 (mod)); + + return scm_module_variable (iface, name); +} + +SCM +scm_private_variable (SCM module_name, SCM name) +{ + SCM mod; + + mod = scm_call_3 (scm_variable_ref (resolve_module_var), module_name, + k_ensure, SCM_BOOL_F); + + if (scm_is_false (mod)) + scm_misc_error ("private-lookup", "Module named ~s does not exist", + scm_list_1 (module_name)); + + return scm_module_variable (mod, name); +} + +SCM +scm_c_public_variable (const char *module_name, const char *name) +{ + return scm_public_variable (convert_module_name (module_name), + scm_from_locale_symbol (name)); +} + +SCM +scm_c_private_variable (const char *module_name, const char *name) +{ + return scm_private_variable (convert_module_name (module_name), + scm_from_locale_symbol (name)); +} + +SCM +scm_public_lookup (SCM module_name, SCM name) +{ + SCM var; + + var = scm_public_variable (module_name, name); + + if (scm_is_false (var)) + scm_misc_error ("public-lookup", "No variable bound to ~s in module ~s", + scm_list_2 (name, module_name)); + + return var; +} + +SCM +scm_private_lookup (SCM module_name, SCM name) +{ + SCM var; + + var = scm_private_variable (module_name, name); + + if (scm_is_false (var)) + scm_misc_error ("private-lookup", "No variable bound to ~s in module ~s", + scm_list_2 (name, module_name)); + + return var; +} + +SCM +scm_c_public_lookup (const char *module_name, const char *name) +{ + return scm_public_lookup (convert_module_name (module_name), + scm_from_locale_symbol (name)); +} + +SCM +scm_c_private_lookup (const char *module_name, const char *name) +{ + return scm_private_lookup (convert_module_name (module_name), + scm_from_locale_symbol (name)); +} + +SCM +scm_public_ref (SCM module_name, SCM name) +{ + return scm_variable_ref (scm_public_lookup (module_name, name)); +} + +SCM +scm_private_ref (SCM module_name, SCM name) +{ + return scm_variable_ref (scm_private_lookup (module_name, name)); +} + +SCM +scm_c_public_ref (const char *module_name, const char *name) +{ + return scm_public_ref (convert_module_name (module_name), + scm_from_locale_symbol (name)); +} + +SCM +scm_c_private_ref (const char *module_name, const char *name) +{ + return scm_private_ref (convert_module_name (module_name), + scm_from_locale_symbol (name)); +} + +SCM scm_c_module_define (SCM module, const char *name, SCM value) { return scm_module_define (module, scm_from_locale_symbol (name), value); @@ -903,6 +1024,7 @@ scm_post_boot_init_modules () default_duplicate_binding_procedures_var = scm_c_lookup ("default-duplicate-binding-procedures"); module_public_interface_var = scm_c_lookup ("module-public-interface"); + k_ensure = scm_from_locale_keyword ("ensure"); scm_module_system_booted_p = 1; } diff --git a/libguile/modules.h b/libguile/modules.h index aef7d3beb..07dc2c3c4 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -3,7 +3,7 @@ #ifndef SCM_MODULES_H #define SCM_MODULES_H -/* Copyright (C) 1998, 2000, 2001, 2002, 2003, 2006, 2007, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1998, 2000, 2001, 2002, 2003, 2006, 2007, 2008, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -93,6 +93,21 @@ SCM_API SCM scm_module_define (SCM module, SCM symbol, SCM val); SCM_API SCM scm_module_export (SCM module, SCM symbol_list); SCM_API SCM scm_module_reverse_lookup (SCM module, SCM variable); +SCM_API SCM scm_public_variable (SCM module_name, SCM name); +SCM_API SCM scm_private_variable (SCM module_name, SCM name); +SCM_API SCM scm_c_public_variable (const char *module_name, const char *name); +SCM_API SCM scm_c_private_variable (const char *module_name, const char *name); + +SCM_API SCM scm_public_lookup (SCM module_name, SCM name); +SCM_API SCM scm_private_lookup (SCM module_name, SCM name); +SCM_API SCM scm_c_public_lookup (const char *module_name, const char *name); +SCM_API SCM scm_c_private_lookup (const char *module_name, const char *name); + +SCM_API SCM scm_public_ref (SCM module_name, SCM name); +SCM_API SCM scm_private_ref (SCM module_name, SCM name); +SCM_API SCM scm_c_public_ref (const char *module_name, const char *name); +SCM_API SCM scm_c_private_ref (const char *module_name, const char *name); + SCM_API SCM scm_c_resolve_module (const char *name); SCM_API SCM scm_resolve_module (SCM name); SCM_API SCM scm_c_define_module (const char *name, diff --git a/libguile/numbers.c b/libguile/numbers.c index f8891fa87..74753812b 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -146,7 +146,7 @@ static double atanh (double x) { return 0.5 * log ((1 + x) / (1 - x)); } #if defined (GUILE_I) -#if HAVE_COMPLEX_DOUBLE +#if defined HAVE_COMPLEX_DOUBLE /* For an SCM object Z which is a complex number (ie. satisfies SCM_COMPLEXP), return its value as a C level "complex double". */ @@ -5668,7 +5668,7 @@ mem2decimal_from_point (SCM result, SCM mem, if (sign == 1) result = scm_product (result, e); else - result = scm_divide2real (result, e); + result = scm_divide (result, e); /* We've seen an exponent, thus the value is implicitly inexact. */ x = INEXACT; @@ -9449,7 +9449,8 @@ SCM_PRIMITIVE_GENERIC (scm_log, "log", 1, 0, 0, { if (SCM_COMPLEXP (z)) { -#if HAVE_COMPLEX_DOUBLE && HAVE_CLOG && defined (SCM_COMPLEX_VALUE) +#if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \ + && defined (SCM_COMPLEX_VALUE) return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z))); #else double re = SCM_COMPLEX_REAL (z); @@ -9534,7 +9535,8 @@ SCM_PRIMITIVE_GENERIC (scm_exp, "exp", 1, 0, 0, { if (SCM_COMPLEXP (z)) { -#if HAVE_COMPLEX_DOUBLE && HAVE_CEXP && defined (SCM_COMPLEX_VALUE) +#if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \ + && defined (SCM_COMPLEX_VALUE) return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z))); #else return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)), @@ -9553,6 +9555,70 @@ SCM_PRIMITIVE_GENERIC (scm_exp, "exp", 1, 0, 0, #undef FUNC_NAME +SCM_DEFINE (scm_i_exact_integer_sqrt, "exact-integer-sqrt", 1, 0, 0, + (SCM k), + "Return two exact non-negative integers @var{s} and @var{r}\n" + "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n" + "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n" + "An error is raised if @var{k} is not an exact non-negative integer.\n" + "\n" + "@lisp\n" + "(exact-integer-sqrt 10) @result{} 3 and 1\n" + "@end lisp") +#define FUNC_NAME s_scm_i_exact_integer_sqrt +{ + SCM s, r; + + scm_exact_integer_sqrt (k, &s, &r); + return scm_values (scm_list_2 (s, r)); +} +#undef FUNC_NAME + +void +scm_exact_integer_sqrt (SCM k, SCM *sp, SCM *rp) +{ + if (SCM_LIKELY (SCM_I_INUMP (k))) + { + scm_t_inum kk = SCM_I_INUM (k); + scm_t_inum uu = kk; + scm_t_inum ss; + + if (SCM_LIKELY (kk > 0)) + { + do + { + ss = uu; + uu = (ss + kk/ss) / 2; + } while (uu < ss); + *sp = SCM_I_MAKINUM (ss); + *rp = SCM_I_MAKINUM (kk - ss*ss); + } + else if (SCM_LIKELY (kk == 0)) + *sp = *rp = SCM_INUM0; + else + scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k, + "exact non-negative integer"); + } + else if (SCM_LIKELY (SCM_BIGP (k))) + { + SCM s, r; + + if (mpz_sgn (SCM_I_BIG_MPZ (k)) < 0) + scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k, + "exact non-negative integer"); + s = scm_i_mkbig (); + r = scm_i_mkbig (); + mpz_sqrtrem (SCM_I_BIG_MPZ (s), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (k)); + scm_remember_upto_here_1 (k); + *sp = scm_i_normbig (s); + *rp = scm_i_normbig (r); + } + else + scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k, + "exact non-negative integer"); +} + + SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0, (SCM z), "Return the square root of @var{z}. Of the two possible roots\n" diff --git a/libguile/numbers.h b/libguile/numbers.h index ab96981c6..d98583039 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -289,6 +289,7 @@ SCM_API SCM scm_log (SCM z); SCM_API SCM scm_log10 (SCM z); SCM_API SCM scm_exp (SCM z); SCM_API SCM scm_sqrt (SCM z); +SCM_API void scm_exact_integer_sqrt (SCM k, SCM *s, SCM *r); SCM_INTERNAL SCM scm_i_min (SCM x, SCM y, SCM rest); SCM_INTERNAL SCM scm_i_max (SCM x, SCM y, SCM rest); @@ -296,6 +297,7 @@ SCM_INTERNAL SCM scm_i_sum (SCM x, SCM y, SCM rest); SCM_INTERNAL SCM scm_i_difference (SCM x, SCM y, SCM rest); SCM_INTERNAL SCM scm_i_product (SCM x, SCM y, SCM rest); SCM_INTERNAL SCM scm_i_divide (SCM x, SCM y, SCM rest); +SCM_INTERNAL SCM scm_i_exact_integer_sqrt (SCM k); /* bignum internal functions */ SCM_INTERNAL SCM scm_i_mkbig (void); diff --git a/libguile/objcodes.c b/libguile/objcodes.c index f4e20f8f2..448badafb 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -23,12 +23,18 @@ #include <string.h> #include <fcntl.h> #include <unistd.h> + +#ifdef HAVE_SYS_MMAN_H #include <sys/mman.h> +#endif + #include <sys/stat.h> #include <sys/types.h> #include <assert.h> #include <alignof.h> +#include <full-read.h> + #include "_scm.h" #include "programs.h" #include "objcodes.h" @@ -44,6 +50,52 @@ verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0); * Objcode type */ +static void +verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr) +#define FUNC_NAME "make_objcode_from_file" +{ + /* The cookie ends with a version of the form M.N, where M is the + major version and N is the minor version. For this Guile to be + able to load an objcode, M must be SCM_OBJCODE_MAJOR_VERSION, and N + must be less than or equal to SCM_OBJCODE_MINOR_VERSION. Since N + is the last character, we do a strict comparison on all but the + last, then a <= on the last one. */ + if (memcmp (cookie, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE) - 1)) + { + SCM args = scm_list_1 (scm_from_latin1_stringn + (cookie, strlen (SCM_OBJCODE_COOKIE))); + if (map_fd >= 0) + { + (void) close (map_fd); +#ifdef HAVE_SYS_MMAN_H + (void) munmap (map_addr, st->st_size); +#endif + } + scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args); + } + + { + char minor_version = cookie[strlen (SCM_OBJCODE_COOKIE) - 1]; + + if (minor_version > SCM_OBJCODE_MINOR_VERSION_STRING[0]) + { + if (map_fd >= 0) + { + (void) close (map_fd); +#ifdef HAVE_SYS_MMAN_H + (void) munmap (map_addr, st->st_size); +#endif + } + + scm_misc_error (FUNC_NAME, "objcode minor version too new (~a > ~a)", + scm_list_2 (scm_from_latin1_stringn (&minor_version, 1), + scm_from_latin1_string + (SCM_OBJCODE_MINOR_VERSION_STRING))); + } + } +} +#undef FUNC_NAME + /* The words in an objcode SCM object are as follows: - scm_tc7_objcode | type | flags - the struct scm_objcode C object @@ -53,77 +105,91 @@ verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0); */ static SCM -make_objcode_by_mmap (int fd) -#define FUNC_NAME "make_objcode_by_mmap" +make_objcode_from_file (int fd) +#define FUNC_NAME "make_objcode_from_file" { int ret; - char *addr; + /* The SCM_OBJCODE_COOKIE is a string literal, and thus has an extra + trailing NUL, hence the - 1. */ + char cookie[sizeof (SCM_OBJCODE_COOKIE) - 1]; struct stat st; - SCM sret = SCM_BOOL_F; - struct scm_objcode *data; ret = fstat (fd, &st); if (ret < 0) SCM_SYSERROR; - if (st.st_size <= sizeof (struct scm_objcode) + strlen (SCM_OBJCODE_COOKIE)) + if (st.st_size <= sizeof (struct scm_objcode) + sizeof cookie) scm_misc_error (FUNC_NAME, "object file too small (~a bytes)", scm_list_1 (SCM_I_MAKINUM (st.st_size))); - addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0); - if (addr == MAP_FAILED) - { - (void) close (fd); - SCM_SYSERROR; - } - - /* The cookie ends with a version of the form M.N, where M is the - major version and N is the minor version. For this Guile to be - able to load an objcode, M must be SCM_OBJCODE_MAJOR_VERSION, and N - must be less than or equal to SCM_OBJCODE_MINOR_VERSION. Since N - is the last character, we do a strict comparison on all but the - last, then a <= on the last one. */ - if (memcmp (addr, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE) - 1)) - { - SCM args = scm_list_1 (scm_from_latin1_stringn - (addr, strlen (SCM_OBJCODE_COOKIE))); - (void) close (fd); - (void) munmap (addr, st.st_size); - scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args); - } - +#ifdef HAVE_SYS_MMAN_H { - char minor_version = addr[strlen (SCM_OBJCODE_COOKIE) - 1]; - - if (minor_version > SCM_OBJCODE_MINOR_VERSION_STRING[0]) - scm_misc_error (FUNC_NAME, "objcode minor version too new (~a > ~a)", - scm_list_2 (scm_from_latin1_stringn (&minor_version, 1), - scm_from_latin1_string - (SCM_OBJCODE_MINOR_VERSION_STRING))); + char *addr; + struct scm_objcode *data; + + addr = mmap (0, st.st_size, PROT_READ, MAP_PRIVATE, fd, 0); + + if (addr == MAP_FAILED) + { + int errno_save = errno; + (void) close (fd); + errno = errno_save; + SCM_SYSERROR; + } + else + { + memcpy (cookie, addr, sizeof cookie); + data = (struct scm_objcode *) (addr + sizeof cookie); + } + + verify_cookie (cookie, &st, fd, addr); + + + if (data->len + data->metalen + != (st.st_size - sizeof (*data) - sizeof cookie)) + { + size_t total_len = sizeof (*data) + data->len + data->metalen; + + (void) close (fd); + (void) munmap (addr, st.st_size); + + scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)", + scm_list_2 (scm_from_size_t (st.st_size), + scm_from_size_t (total_len))); + } + + /* FIXME: we leak ourselves and the file descriptor. but then again so does + dlopen(). */ + return scm_permanent_object + (scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0), + (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)), + SCM_UNPACK (scm_from_int (fd)), 0)); } +#else + { + SCM bv = scm_c_make_bytevector (st.st_size - sizeof cookie); - data = (struct scm_objcode*)(addr + strlen (SCM_OBJCODE_COOKIE)); + if (full_read (fd, cookie, sizeof cookie) != sizeof cookie + || full_read (fd, SCM_BYTEVECTOR_CONTENTS (bv), + SCM_BYTEVECTOR_LENGTH (bv)) != SCM_BYTEVECTOR_LENGTH (bv)) + { + int errno_save = errno; + (void) close (fd); + errno = errno_save; + SCM_SYSERROR; + } - if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (SCM_OBJCODE_COOKIE))) - { - (void) close (fd); - (void) munmap (addr, st.st_size); - scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)", - scm_list_2 (scm_from_size_t (st.st_size), - scm_from_uint32 (sizeof (*data) + data->len - + data->metalen))); - } + (void) close (fd); - sret = scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0), - (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)), - SCM_UNPACK (scm_from_int (fd)), 0); + verify_cookie (cookie, &st, -1, NULL); - /* FIXME: we leak ourselves and the file descriptor. but then again so does - dlopen(). */ - return scm_permanent_object (sret); + return scm_bytecode_to_objcode (bv); + } +#endif } #undef FUNC_NAME + SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr) #define FUNC_NAME "make-objcode-slice" @@ -233,7 +299,7 @@ SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0, free (c_file); if (fd < 0) SCM_SYSERROR; - return make_objcode_by_mmap (fd); + return make_objcode_from_file (fd); } #undef FUNC_NAME diff --git a/libguile/ports.c b/libguile/ports.c index b65650e95..6e0ae6c8b 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -352,7 +352,7 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, if (count) { - result = scm_i_make_string (count, &data); + result = scm_i_make_string (count, &data, 0); scm_take_from_input_buffers (port, data, count); } else @@ -522,12 +522,9 @@ static void finalize_port (GC_PTR, GC_PTR); static SCM_C_INLINE_KEYWORD void register_finalizer_for_port (SCM port) { - long port_type; GC_finalization_proc prev_finalizer; GC_PTR prev_finalization_data; - port_type = SCM_TC2PTOBNUM (SCM_CELL_TYPE (port)); - /* Register a finalizer for PORT so that its iconv CDs get freed and optionally its type's `free' function gets called. */ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (port), finalize_port, 0, @@ -661,6 +658,19 @@ scm_i_remove_port (SCM port) scm_port_non_buffer (p); p->putback_buf = NULL; p->putback_buf_size = 0; + + if (p->input_cd != (iconv_t) -1) + { + iconv_close (p->input_cd); + p->input_cd = (iconv_t) -1; + } + + if (p->output_cd != (iconv_t) -1) + { + iconv_close (p->output_cd); + p->output_cd = (iconv_t) -1; + } + SCM_SETPTAB_ENTRY (port, 0); scm_hashq_remove_x (scm_i_port_weak_hash, port); @@ -1929,9 +1939,8 @@ SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0, SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0, (SCM port), - "Return the filename associated with @var{port}. This function returns\n" - "the strings \"standard input\", \"standard output\" and \"standard error\"\n" - "when called on the current input, output and error ports respectively.") + "Return the filename associated with @var{port}, or @code{#f}\n" + "if no filename is associated with the port.") #define FUNC_NAME s_scm_port_filename { port = SCM_COERCE_OUTPORT (port); @@ -2099,6 +2108,7 @@ SCM_DEFINE (scm_set_port_encoding_x, "set-port-encoding!", 2, 0, 0, enc_str = scm_to_locale_string (enc); scm_i_set_port_encoding_x (port, enc_str); + free (enc_str); return SCM_UNSPECIFIED; } diff --git a/libguile/posix.c b/libguile/posix.c index 97e30df2b..a5c72624c 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1713,12 +1713,10 @@ SCM_DEFINE (scm_nice, "nice", 1, 0, 0, "The return value is unspecified.") #define FUNC_NAME s_scm_nice { - int nice_value; - /* nice() returns "prio-NZERO" on success or -1 on error, but -1 can arise from "prio-NZERO", so an error must be detected from errno changed */ errno = 0; - nice_value = nice (scm_to_int (incr)); + nice (scm_to_int (incr)); if (errno != 0) SCM_SYSERROR; diff --git a/libguile/print.c b/libguile/print.c index 59b109380..139956624 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -309,15 +309,10 @@ print_circref (SCM port, scm_print_state *pstate, SCM ref) /* Print the name of a symbol. */ static int -quote_keywordish_symbol (SCM symbol) +quote_keywordish_symbols (void) { - SCM option; + SCM option = SCM_PRINT_KEYWORD_STYLE; - if (scm_i_symbol_ref (symbol, 0) != ':' - && scm_i_symbol_ref (symbol, scm_i_symbol_length (symbol) - 1) != ':') - return 0; - - option = SCM_PRINT_KEYWORD_STYLE; if (scm_is_false (option)) return 0; if (scm_is_eq (option, sym_reader)) @@ -325,91 +320,114 @@ quote_keywordish_symbol (SCM symbol) return 1; } -void -scm_i_print_symbol_name (SCM str, SCM port) +#define INITIAL_IDENTIFIER_MASK \ + (UC_CATEGORY_MASK_Lu | UC_CATEGORY_MASK_Ll | UC_CATEGORY_MASK_Lt \ + | UC_CATEGORY_MASK_Lm | UC_CATEGORY_MASK_Lo | UC_CATEGORY_MASK_Mn \ + | UC_CATEGORY_MASK_Nl | UC_CATEGORY_MASK_No | UC_CATEGORY_MASK_Pd \ + | UC_CATEGORY_MASK_Pc | UC_CATEGORY_MASK_Po | UC_CATEGORY_MASK_Sc \ + | UC_CATEGORY_MASK_Sm | UC_CATEGORY_MASK_Sk | UC_CATEGORY_MASK_So \ + | UC_CATEGORY_MASK_Co) + +#define SUBSEQUENT_IDENTIFIER_MASK \ + (INITIAL_IDENTIFIER_MASK \ + | UC_CATEGORY_MASK_Nd | UC_CATEGORY_MASK_Mc | UC_CATEGORY_MASK_Me) + +static int +symbol_has_extended_read_syntax (SCM sym) { - /* This points to the first character that has not yet been written to the - * port. */ - size_t pos = 0; - /* This points to the character we're currently looking at. */ - size_t end; - /* If the name contains weird characters, we'll escape them with - * backslashes and set this flag; it indicates that we should surround the - * name with "#{" and "}#". */ - int weird = 0; - /* Backslashes are not sufficient to make a name weird, but if a name is - * weird because of other characters, backslahes need to be escaped too. - * The first time we see a backslash, we set maybe_weird, and mw_pos points - * to the backslash. Then if the name turns out to be weird, we re-process - * everything starting from mw_pos. - * We could instead make backslashes always weird. This is not necessary - * to ensure that the output is (read)-able, but it would make this code - * simpler and faster. */ - int maybe_weird = 0; - size_t mw_pos = 0; - size_t len = scm_i_symbol_length (str); - scm_t_wchar str0 = scm_i_symbol_ref (str, 0); - - if (len == 0 || str0 == '\'' || str0 == '`' || str0 == ',' - || quote_keywordish_symbol (str) - || (str0 == '.' && len == 1) - || scm_is_true (scm_i_string_to_number (scm_symbol_to_string (str), 10))) + size_t pos, len = scm_i_symbol_length (sym); + scm_t_wchar c; + + /* The empty symbol. */ + if (len == 0) + return 1; + + c = scm_i_symbol_ref (sym, 0); + + /* Single dot; conflicts with dotted-pair notation. */ + if (len == 1 && c == '.') + return 1; + + /* Other initial-character constraints. */ + if (c == '\'' || c == '`' || c == ',' || c == '"' || c == ';' || c == '#') + return 1; + + /* Keywords can be identified by trailing colons too. */ + if (c == ':' || scm_i_symbol_ref (sym, len - 1) == ':') + return quote_keywordish_symbols (); + + /* Number-ish symbols. */ + if (scm_is_true (scm_i_string_to_number (scm_symbol_to_string (sym), 10))) + return 1; + + /* Other disallowed first characters. */ + if (!uc_is_general_category_withtable (c, INITIAL_IDENTIFIER_MASK)) + return 1; + + /* Otherwise, any character that's in the identifier category mask is + fine to pass through as-is, provided it's not one of the ASCII + delimiters like `;'. */ + for (pos = 1; pos < len; pos++) { - scm_lfwrite ("#{", 2, port); - weird = 1; + c = scm_i_symbol_ref (sym, pos); + if (!uc_is_general_category_withtable (c, SUBSEQUENT_IDENTIFIER_MASK)) + return 1; + else if (c == '"' || c == ';' || c == '#') + return 1; } - for (end = pos; end < len; ++end) - switch (scm_i_symbol_ref (str, end)) - { -#ifdef BRACKETS_AS_PARENS - case '[': - case ']': -#endif - case '(': - case ')': - case '"': - case ';': - case '#': - case SCM_WHITE_SPACES: - case SCM_LINE_INCREMENTORS: - weird_handler: - if (maybe_weird) - { - end = mw_pos; - maybe_weird = 0; - } - if (!weird) - { - scm_lfwrite ("#{", 2, port); - weird = 1; - } - if (pos < end) - scm_lfwrite_substr (scm_symbol_to_string (str), pos, end, port); - { - char buf[2]; - buf[0] = '\\'; - buf[1] = (char) (unsigned char) scm_i_symbol_ref (str, end); - scm_lfwrite (buf, 2, port); - } - pos = end + 1; - break; - case '\\': - if (weird) - goto weird_handler; - if (!maybe_weird) - { - maybe_weird = 1; - mw_pos = pos; - } - break; - default: - break; - } - if (pos < end) - scm_lfwrite_substr (scm_symbol_to_string (str), pos, end, port); - if (weird) - scm_lfwrite ("}#", 2, port); + return 0; +} + +static void +print_normal_symbol (SCM sym, SCM port) +{ + scm_display (scm_symbol_to_string (sym), port); +} + +static void +print_extended_symbol (SCM sym, SCM port) +{ + size_t pos, len; + scm_t_string_failed_conversion_handler strategy; + + len = scm_i_symbol_length (sym); + strategy = scm_i_get_conversion_strategy (port); + + scm_lfwrite ("#{", 2, port); + + for (pos = 0; pos < len; pos++) + { + scm_t_wchar c = scm_i_symbol_ref (sym, pos); + + if (uc_is_general_category_withtable (c, + SUBSEQUENT_IDENTIFIER_MASK + | UC_CATEGORY_MASK_Zs)) + { + if (!display_character (c, port, strategy)) + scm_encoding_error ("print_extended_symbol", errno, + "cannot convert to output locale", + port, SCM_MAKE_CHAR (c)); + } + else + { + display_string ("\\x", 1, 2, port, iconveh_question_mark); + scm_intprint (c, 16, port); + display_character (';', port, iconveh_question_mark); + } + } + + scm_lfwrite ("}#", 2, port); +} + +/* FIXME: allow R6RS hex escapes instead of #{...}#. */ +void +scm_i_print_symbol_name (SCM sym, SCM port) +{ + if (symbol_has_extended_read_syntax (sym)) + print_extended_symbol (sym, port); + else + print_normal_symbol (sym, port); } void @@ -862,6 +880,8 @@ display_string (const void *str, int narrow_p, if (SCM_UNLIKELY (done == (size_t) -1)) { + int errno_save = errno; + /* Reset the `iconv' state. */ iconv (pt->output_cd, NULL, NULL, NULL, NULL); @@ -873,7 +893,7 @@ display_string (const void *str, int narrow_p, codepoints_read = offsets[input - utf8_buf] - printed; printed += codepoints_read; - if (errno == EILSEQ && + if (errno_save == EILSEQ && strategy != SCM_FAILED_CONVERSION_ERROR) { /* Conversion failed somewhere in INPUT and we want to @@ -1282,8 +1302,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, else if (scm_is_false (destination)) { fReturnString = 1; - port = scm_mkstrport (SCM_INUM0, - scm_make_string (SCM_INUM0, SCM_UNDEFINED), + port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_OPN | SCM_WRTNG, FUNC_NAME); destination = port; diff --git a/libguile/procs.c b/libguile/procs.c index 2b7225efe..a096591df 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -149,7 +149,8 @@ SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0, SCM_GASSERT1 (SCM_STRUCTP (proc), g_scm_setter, proc, SCM_ARG1, FUNC_NAME); if (SCM_STRUCT_SETTER_P (proc)) return SCM_STRUCT_SETTER (proc); - if (SCM_PUREGENERICP (proc)) + if (SCM_PUREGENERICP (proc) + && SCM_IS_A_P (proc, scm_class_generic_with_setter)) /* FIXME: might not be an accessor */ return SCM_GENERIC_SETTER (proc); SCM_WTA_DISPATCH_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME); diff --git a/libguile/pthread-threads.h b/libguile/pthread-threads.h index ca72f1674..4c67b1857 100644 --- a/libguile/pthread-threads.h +++ b/libguile/pthread-threads.h @@ -3,7 +3,7 @@ #ifndef SCM_PTHREADS_THREADS_H #define SCM_PTHREADS_THREADS_H -/* Copyright (C) 2002, 2005, 2006 Free Software Foundation, Inc. +/* Copyright (C) 2002, 2005, 2006, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -29,24 +29,39 @@ #include <pthread.h> #include <sched.h> -/* `libgc' intercepts pthread calls by defining wrapping macros. */ +/* `libgc' defines wrapper procedures for pthread calls. */ #include "libguile/bdw-gc.h" /* Threads */ #define scm_i_pthread_t pthread_t #define scm_i_pthread_self pthread_self -#define scm_i_pthread_create pthread_create -#define scm_i_pthread_detach pthread_detach +#define scm_i_pthread_create GC_pthread_create +#define scm_i_pthread_detach GC_pthread_detach + +#if SCM_HAVE_GC_PTHREAD_EXIT +#define scm_i_pthread_exit GC_pthread_exit +#else #define scm_i_pthread_exit pthread_exit +#endif + +#if SCM_HAVE_GC_PTHREAD_CANCEL +#define scm_i_pthread_cancel GC_pthread_cancel +#else #define scm_i_pthread_cancel pthread_cancel +#endif + #define scm_i_pthread_cleanup_push pthread_cleanup_push #define scm_i_pthread_cleanup_pop pthread_cleanup_pop #define scm_i_sched_yield sched_yield /* Signals */ +#if SCM_HAVE_GC_PTHREAD_SIGMASK +#define scm_i_pthread_sigmask GC_pthread_sigmask +#else #define scm_i_pthread_sigmask pthread_sigmask +#endif /* Mutexes */ diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 8058ca074..7473db94b 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -136,7 +136,7 @@ bip_seek (SCM port, scm_t_off offset, int whence) /* Fall through. */ case SEEK_SET: - if (c_port->read_buf + offset < c_port->read_end) + if (c_port->read_buf + offset <= c_port->read_end) { c_port->read_pos = c_port->read_buf + offset; c_result = offset; @@ -1222,6 +1222,46 @@ SCM_DEFINE (scm_i_make_transcoded_port, #undef FUNC_NAME +/* Textual I/O */ + +SCM_DEFINE (scm_get_string_n_x, + "get-string-n!", 4, 0, 0, + (SCM port, SCM str, SCM start, SCM count), + "Read up to @var{count} characters from @var{port} into " + "@var{str}, starting at @var{start}. If no characters " + "can be read before the end of file is encountered, the end " + "of file object is returned. Otherwise, the number of " + "characters read is returned.") +#define FUNC_NAME s_scm_get_string_n_x +{ + size_t c_start, c_count, c_len, c_end, j; + scm_t_wchar c; + + SCM_VALIDATE_OPINPORT (1, port); + SCM_VALIDATE_STRING (2, str); + c_len = scm_c_string_length (str); + c_start = scm_to_size_t (start); + c_count = scm_to_size_t (count); + c_end = c_start + c_count; + + if (SCM_UNLIKELY (c_end > c_len)) + scm_out_of_range (FUNC_NAME, count); + + for (j = c_start; j < c_end; j++) + { + c = scm_getc (port); + if (c == EOF) + { + size_t chars_read = j - c_start; + return chars_read == 0 ? SCM_EOF_VAL : scm_from_size_t (chars_read); + } + scm_c_string_set_x (str, j, SCM_MAKE_CHAR (c)); + } + return count; +} +#undef FUNC_NAME + + /* Initialization. */ void diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h index edde00520..2ae3e765b 100644 --- a/libguile/r6rs-ports.h +++ b/libguile/r6rs-ports.h @@ -1,7 +1,7 @@ #ifndef SCM_R6RS_PORTS_H #define SCM_R6RS_PORTS_H -/* Copyright (C) 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -38,6 +38,7 @@ SCM_API SCM scm_put_u8 (SCM, SCM); SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM); SCM_API SCM scm_open_bytevector_output_port (SCM); SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_get_string_n_x (SCM, SCM, SCM, SCM); SCM_API void scm_init_r6rs_ports (void); SCM_INTERNAL void scm_register_r6rs_ports (void); diff --git a/libguile/read.c b/libguile/read.c index 5f0be3148..4b6828b8a 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -516,7 +516,7 @@ scm_read_string (int chr, SCM port) unsigned c_str_len = 0; scm_t_wchar c; - str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL); + str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL, 0); while ('"' != (c = scm_getc (port))) { if (c == EOF) @@ -528,7 +528,7 @@ scm_read_string (int chr, SCM port) if (c_str_len + 1 >= scm_i_string_length (str)) { - SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL); + SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL, 0); str = scm_string_append (scm_list_2 (str, addy)); } @@ -1116,13 +1116,9 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port) { int bang_seen = 0; - /* We can use the get_byte here because there is no need to get the - locale correct when reading comments. This presumes that - hash and exclamation points always represent themselves no - matter what the source encoding is.*/ for (;;) { - int c = scm_get_byte_or_eof (port); + int c = scm_getc (port); if (c == EOF) scm_i_input_error ("skip_block_comment", port, @@ -1234,9 +1230,9 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port) #{This is all a symbol name}# So here, CHR is expected to be `{'. */ - int saw_brace = 0, finished = 0; + int saw_brace = 0; size_t len = 0; - SCM buf = scm_i_make_string (1024, NULL); + SCM buf = scm_i_make_string (1024, NULL, 0); buf = scm_i_string_start_writing (buf); @@ -1246,36 +1242,75 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port) { if (chr == '#') { - finished = 1; break; } else { saw_brace = 0; scm_i_string_set_x (buf, len++, '}'); - scm_i_string_set_x (buf, len++, chr); } } - else if (chr == '}') + + if (chr == '}') saw_brace = 1; + else if (chr == '\\') + { + /* It used to be that print.c would print extended-read-syntax + symbols with backslashes before "non-standard" chars, but + this routine wouldn't do anything with those escapes. + Bummer. What we've done is to change print.c to output + R6RS hex escapes for those characters, relying on the fact + that the extended read syntax would never put a `\' before + an `x'. For now, we just ignore other instances of + backslash in the string. */ + switch ((chr = scm_getc (port))) + { + case EOF: + goto done; + case 'x': + { + scm_t_wchar c; + + SCM_READ_HEX_ESCAPE (10, ';'); + scm_i_string_set_x (buf, len++, c); + break; + + str_eof: + chr = EOF; + goto done; + + bad_escaped: + scm_i_string_stop_writing (); + scm_i_input_error ("scm_read_extended_symbol", port, + "illegal character in escape sequence: ~S", + scm_list_1 (SCM_MAKE_CHAR (c))); + break; + } + default: + scm_i_string_set_x (buf, len++, chr); + break; + } + } else - scm_i_string_set_x (buf, len++, chr); + scm_i_string_set_x (buf, len++, chr); if (len >= scm_i_string_length (buf) - 2) { SCM addy; scm_i_string_stop_writing (); - addy = scm_i_make_string (1024, NULL); + addy = scm_i_make_string (1024, NULL, 0); buf = scm_string_append (scm_list_2 (buf, addy)); len = 0; buf = scm_i_string_start_writing (buf); } - - if (finished) - break; } + + done: scm_i_string_stop_writing (); + if (chr == EOF) + scm_i_input_error ("scm_read_extended_symbol", port, + "end of file while reading symbol", SCM_EOL); return (scm_string_to_symbol (scm_c_substring (buf, 0, len))); } @@ -1333,6 +1368,7 @@ scm_read_sharp (scm_t_wchar chr, SCM port) case 's': case 'u': case 'f': + case 'c': /* This one may return either a boolean or an SRFI-4 vector. */ return (scm_read_srfi4_vector (chr, port)); case 'v': @@ -1352,7 +1388,6 @@ scm_read_sharp (scm_t_wchar chr, SCM port) #if SCM_ENABLE_DEPRECATED /* See below for 'i' and 'e'. */ case 'a': - case 'c': case 'y': case 'h': case 'l': @@ -1654,6 +1689,7 @@ scm_get_hash_procedure (int c) char * scm_i_scan_for_encoding (SCM port) { + scm_t_port *pt; char header[SCM_ENCODING_SEARCH_SIZE+1]; size_t bytes_read, encoding_length, i; char *encoding = NULL; @@ -1661,15 +1697,46 @@ scm_i_scan_for_encoding (SCM port) char *pos, *encoding_start; int in_comment; - if (SCM_FPORTP (port) && !SCM_FDES_RANDOM_P (SCM_FPORT_FDES (port))) - /* PORT is a non-seekable file port (e.g., as created by Bash when using - "guile <(echo '(display "hello")')") so bail out. */ - return NULL; + pt = SCM_PTAB_ENTRY (port); + + if (pt->rw_active == SCM_PORT_WRITE) + scm_flush (port); + + if (pt->rw_random) + pt->rw_active = SCM_PORT_READ; + + if (pt->read_pos == pt->read_end) + { + /* We can use the read buffer, and thus avoid a seek. */ + if (scm_fill_input (port) == EOF) + return NULL; + + bytes_read = pt->read_end - pt->read_pos; + if (bytes_read > SCM_ENCODING_SEARCH_SIZE) + bytes_read = SCM_ENCODING_SEARCH_SIZE; - bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE); - header[bytes_read] = '\0'; + if (bytes_read <= 1) + /* An unbuffered port -- don't scan. */ + return NULL; + + memcpy (header, pt->read_pos, bytes_read); + header[bytes_read] = '\0'; + } + else + { + /* Try to read some bytes and then seek back. Not all ports + support seeking back; and indeed some file ports (like + /dev/urandom) will succeed on an lseek (fd, 0, SEEK_CUR)---the + check performed by SCM_FPORT_FDES---but fail to seek + backwards. Hence this block comes second. We prefer to use + the read buffer in-place. */ + if (SCM_FPORTP (port) && !SCM_FDES_RANDOM_P (SCM_FPORT_FDES (port))) + return NULL; - scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET)); + bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE); + header[bytes_read] = '\0'; + scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET)); + } if (bytes_read > 3 && header[0] == '\xef' && header[1] == '\xbb' && header[2] == '\xbf') @@ -1718,22 +1785,26 @@ scm_i_scan_for_encoding (SCM port) pos = encoding_start; while (pos >= header) { - if (*pos == '\n') + if (*pos == ';') + { + in_comment = 1; + break; + } + else if (*pos == '\n' || pos == header) { /* This wasn't in a semicolon comment. Check for a hash-bang comment. */ char *beg = strstr (header, "#!"); char *end = strstr (header, "!#"); - if (beg < encoding_start && encoding_start + encoding_length < end) + if (beg < encoding_start && encoding_start + encoding_length <= end) in_comment = 1; break; } - if (*pos == ';') - { - in_comment = 1; - break; - } - pos --; + else + { + pos --; + continue; + } } if (!in_comment) /* This wasn't in a comment */ @@ -1761,6 +1832,8 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0, char *enc; SCM s_enc; + SCM_VALIDATE_OPINPORT (SCM_ARG1, port); + enc = scm_i_scan_for_encoding (port); if (enc == NULL) return SCM_BOOL_F; diff --git a/libguile/snarf.h b/libguile/snarf.h index 9bb998eb0..7d22a3617 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -53,11 +53,17 @@ * The SCM_SNARF_INIT text goes into the corresponding .x file * up through the first occurrence of SCM_SNARF_DOC_START on that * line, if any. + * + * Some debugging options can cause the preprocessor to echo #define + * directives to its output. Keeping the snarfing markers on separate + * lines prevents guile-snarf from inadvertently snarfing the definition + * of SCM_SNARF_INIT if those options are in effect. */ #ifdef SCM_MAGIC_SNARF_INITS # define SCM_SNARF_HERE(X) -# define SCM_SNARF_INIT(X) ^^ X ^:^ +# define SCM_SNARF_INIT_PREFIX ^^ +# define SCM_SNARF_INIT(X) SCM_SNARF_INIT_PREFIX X ^:^ # define SCM_SNARF_DOCS(TYPE, CNAME, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) #else # ifdef SCM_MAGIC_SNARF_DOCS diff --git a/libguile/socket.c b/libguile/socket.c index 10597081d..632dd4f40 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1426,7 +1426,7 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, "use a bytevector instead."); len = scm_i_string_length (buf); - msg = scm_i_make_string (len, &dest); + msg = scm_i_make_string (len, &dest, 0); SCM_SYSCALL (rv = recv (fd, dest, len, flg)); scm_string_copy_x (buf, scm_from_int (0), msg, scm_from_int (0), scm_from_size_t (len)); diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c index ab933c2ad..5bba81c7f 100644 --- a/libguile/srfi-13.c +++ b/libguile/srfi-13.c @@ -251,14 +251,14 @@ SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0, if (wide) { scm_t_wchar *wbuf = NULL; - res = scm_i_make_wide_string (clen, &wbuf); + res = scm_i_make_wide_string (clen, &wbuf, 0); memcpy (wbuf, buf, clen * sizeof (scm_t_wchar)); free (buf); } else { char *nbuf = NULL; - res = scm_i_make_string (clen, &nbuf); + res = scm_i_make_string (clen, &nbuf, 0); for (i = 0; i < clen; i ++) nbuf[i] = (unsigned char) buf[i]; free (buf); @@ -336,7 +336,7 @@ SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0, if (i < 0) SCM_WRONG_TYPE_ARG (1, chrs); - result = scm_i_make_string (i, &data); + result = scm_i_make_string (i, &data, 0); { SCM rest; @@ -439,7 +439,7 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, SCM_MISC_ERROR ("strict-infix grammar requires non-empty list", SCM_EOL); - result = scm_i_make_string (0, NULL); + result = scm_i_make_string (0, NULL, 0); tmp = ls; switch (gram) @@ -1181,7 +1181,9 @@ SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0, len1 = scm_i_string_length (s1); len2 = scm_i_string_length (s2); - if (SCM_LIKELY (len1 == len2)) + if (len1 != len2) + return SCM_BOOL_F; + else { if (!scm_i_is_narrow_string (s1)) len1 *= 4; @@ -2484,7 +2486,7 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0, MY_VALIDATE_SUBSTRING_SPEC (2, s, 3, start, cstart, 4, end, cend); - result = scm_i_make_string (cend - cstart, NULL); + result = scm_i_make_string (cend - cstart, NULL, 0); p = 0; while (cstart < cend) { @@ -2622,7 +2624,7 @@ SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0, ans = base; } else - ans = scm_i_make_string (0, NULL); + ans = scm_i_make_string (0, NULL, 0); if (!SCM_UNBNDP (make_final)) SCM_VALIDATE_PROC (6, make_final); @@ -2634,7 +2636,7 @@ SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0, SCM ch = scm_call_1 (f, seed); if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); - str = scm_i_make_string (1, NULL); + str = scm_i_make_string (1, NULL, 0); str = scm_i_string_start_writing (str); scm_i_string_set_x (str, i, SCM_CHAR (ch)); scm_i_string_stop_writing (); @@ -2688,7 +2690,7 @@ SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0, ans = base; } else - ans = scm_i_make_string (0, NULL); + ans = scm_i_make_string (0, NULL, 0); if (!SCM_UNBNDP (make_final)) SCM_VALIDATE_PROC (6, make_final); @@ -2700,7 +2702,7 @@ SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0, SCM ch = scm_call_1 (f, seed); if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); - str = scm_i_make_string (1, NULL); + str = scm_i_make_string (1, NULL, 0); str = scm_i_string_start_writing (str); scm_i_string_set_x (str, i, SCM_CHAR (ch)); scm_i_string_stop_writing (); @@ -2815,7 +2817,7 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, if (cstart == cend && cfrom != cto) SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL); - result = scm_i_make_string (cto - cfrom, NULL); + result = scm_i_make_string (cto - cfrom, NULL, 0); result = scm_i_string_start_writing (result); p = 0; @@ -3127,7 +3129,7 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, else { size_t dst = 0; - result = scm_i_make_string (count, NULL); + result = scm_i_make_string (count, NULL, 0); result = scm_i_string_start_writing (result); /* decrement "count" in this loop as well as using idx, so that if @@ -3237,7 +3239,7 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, { int i = 0; /* new string for retained portion */ - result = scm_i_make_string (count, NULL); + result = scm_i_make_string (count, NULL, 0); result = scm_i_string_start_writing (result); /* decrement "count" in this loop as well as using idx, so that if another thread is simultaneously changing "s" there's no chance @@ -3279,7 +3281,7 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, { size_t i = 0; /* new string for retained portion */ - result = scm_i_make_string (count, NULL); + result = scm_i_make_string (count, NULL, 0); result = scm_i_string_start_writing (result); /* decrement "count" in this loop as well as using idx, so that if diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c index b22471de4..e2f66681a 100644 --- a/libguile/srfi-14.c +++ b/libguile/srfi-14.c @@ -1515,9 +1515,9 @@ SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0, count = scm_to_int (scm_char_set_size (cs)); if (wide) - result = scm_i_make_wide_string (count, &wbuf); + result = scm_i_make_wide_string (count, &wbuf, 0); else - result = scm_i_make_string (count, &buf); + result = scm_i_make_string (count, &buf, 0); for (k = 0; k < cs_data->len; k++) for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) diff --git a/libguile/stacks.c b/libguile/stacks.c index 267b3c404..31bd91b13 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -247,7 +247,6 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, #define FUNC_NAME s_scm_make_stack { long n; - int maxp; SCM frame; SCM stack; SCM inner_cut, outer_cut; @@ -289,7 +288,6 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, /* Count number of frames. Also get stack id tag and check whether there are more stackframes than we want to record (SCM_BACKTRACE_MAXDEPTH). */ - maxp = 0; n = stack_depth (frame); /* Make the stack object. */ diff --git a/libguile/strings.c b/libguile/strings.c index b13cb780f..bf637041c 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -262,30 +262,34 @@ SCM scm_nullstr; /* Create a scheme string with space for LEN 8-bit Latin-1-encoded characters. CHARSP, if not NULL, will be set to location of the - char array. */ + char array. If READ_ONLY_P, the returned string is read-only; + otherwise it is writable. */ SCM -scm_i_make_string (size_t len, char **charsp) +scm_i_make_string (size_t len, char **charsp, int read_only_p) { SCM buf = make_stringbuf (len); SCM res; if (charsp) *charsp = (char *) STRINGBUF_CHARS (buf); - res = scm_double_cell (STRING_TAG, SCM_UNPACK(buf), - (scm_t_bits)0, (scm_t_bits) len); + res = scm_double_cell (read_only_p ? RO_STRING_TAG : STRING_TAG, + SCM_UNPACK (buf), + (scm_t_bits) 0, (scm_t_bits) len); return res; } /* Create a scheme string with space for LEN 32-bit UCS-4-encoded characters. CHARSP, if not NULL, will be set to location of the - character array. */ + character array. If READ_ONLY_P, the returned string is read-only; + otherwise it is writable. */ SCM -scm_i_make_wide_string (size_t len, scm_t_wchar **charsp) +scm_i_make_wide_string (size_t len, scm_t_wchar **charsp, int read_only_p) { SCM buf = make_wide_stringbuf (len); SCM res; if (charsp) *charsp = STRINGBUF_WIDE_CHARS (buf); - res = scm_double_cell (STRING_TAG, SCM_UNPACK (buf), + res = scm_double_cell (read_only_p ? RO_STRING_TAG : STRING_TAG, + SCM_UNPACK (buf), (scm_t_bits) 0, (scm_t_bits) len); return res; } @@ -889,7 +893,7 @@ SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str), { size_t len = STRINGBUF_LENGTH (buf); char *cbuf; - SCM sbc = scm_i_make_string (len, &cbuf); + SCM sbc = scm_i_make_string (len, &cbuf, 0); memcpy (cbuf, STRINGBUF_CHARS (buf), len); e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"), sbc); @@ -898,7 +902,7 @@ SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str), { size_t len = STRINGBUF_LENGTH (buf); scm_t_wchar *cbuf; - SCM sbc = scm_i_make_wide_string (len, &cbuf); + SCM sbc = scm_i_make_wide_string (len, &cbuf, 0); u32_cpy ((scm_t_uint32 *) cbuf, (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len); e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"), @@ -962,7 +966,7 @@ SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym), { size_t len = STRINGBUF_LENGTH (buf); char *cbuf; - SCM sbc = scm_i_make_string (len, &cbuf); + SCM sbc = scm_i_make_string (len, &cbuf, 0); memcpy (cbuf, STRINGBUF_CHARS (buf), len); e4 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"), sbc); @@ -971,7 +975,7 @@ SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym), { size_t len = STRINGBUF_LENGTH (buf); scm_t_wchar *cbuf; - SCM sbc = scm_i_make_wide_string (len, &cbuf); + SCM sbc = scm_i_make_wide_string (len, &cbuf, 0); u32_cpy ((scm_t_uint32 *) cbuf, (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len); e4 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"), @@ -1066,7 +1070,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, { char *buf; - result = scm_i_make_string (len, NULL); + result = scm_i_make_string (len, NULL, 0); result = scm_i_string_start_writing (result); buf = scm_i_string_writable_chars (result); while (len > 0 && scm_is_pair (rest)) @@ -1083,7 +1087,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, { scm_t_wchar *buf; - result = scm_i_make_wide_string (len, NULL); + result = scm_i_make_wide_string (len, NULL, 0); result = scm_i_string_start_writing (result); buf = scm_i_string_writable_wide_chars (result); while (len > 0 && scm_is_pair (rest)) @@ -1125,7 +1129,7 @@ scm_c_make_string (size_t len, SCM chr) { size_t p; char *contents = NULL; - SCM res = scm_i_make_string (len, &contents); + SCM res = scm_i_make_string (len, &contents, 0); /* If no char is given, initialize string contents to NULL. */ if (SCM_UNBNDP (chr)) @@ -1372,9 +1376,9 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, } data.narrow = NULL; if (!wide) - res = scm_i_make_string (len, &data.narrow); + res = scm_i_make_string (len, &data.narrow, 0); else - res = scm_i_make_wide_string (len, &data.wide); + res = scm_i_make_wide_string (len, &data.wide, 0); for (l = args; !scm_is_null (l); l = SCM_CDR (l)) { @@ -1419,8 +1423,8 @@ scm_encoding_error (const char *subr, int err, const char *message, SCM port, SCM chr) { scm_throw (scm_encoding_error_key, - scm_list_n (scm_from_locale_string (subr), - scm_from_locale_string (message), + scm_list_n (scm_from_latin1_string (subr), + scm_from_latin1_string (message), scm_from_int (err), port, chr, SCM_UNDEFINED)); @@ -1432,8 +1436,8 @@ void scm_decoding_error (const char *subr, int err, const char *message, SCM port) { scm_throw (scm_decoding_error_key, - scm_list_n (scm_from_locale_string (subr), - scm_from_locale_string (message), + scm_list_n (scm_from_latin1_string (subr), + scm_from_latin1_string (message), scm_from_int (err), port, SCM_UNDEFINED)); @@ -1463,7 +1467,7 @@ scm_from_stringn (const char *str, size_t len, const char *encoding, { /* If encoding is null, use Latin-1. */ char *buf; - res = scm_i_make_string (len, &buf); + res = scm_i_make_string (len, &buf, 0); memcpy (buf, str, len); return res; } @@ -1502,7 +1506,7 @@ scm_from_stringn (const char *str, size_t len, const char *encoding, if (!wide) { char *dst; - res = scm_i_make_string (u32len, &dst); + res = scm_i_make_string (u32len, &dst, 0); for (i = 0; i < u32len; i ++) dst[i] = (unsigned char) u32[i]; dst[u32len] = '\0'; @@ -1510,7 +1514,7 @@ scm_from_stringn (const char *str, size_t len, const char *encoding, else { scm_t_wchar *wdst; - res = scm_i_make_wide_string (u32len, &wdst); + res = scm_i_make_wide_string (u32len, &wdst, 0); u32_cpy ((scm_t_uint32 *) wdst, (scm_t_uint32 *) u32, u32len); wdst[u32len] = 0; } @@ -1528,25 +1532,8 @@ scm_from_locale_string (const char *str) SCM scm_from_locale_stringn (const char *str, size_t len) { - const char *enc; - scm_t_string_failed_conversion_handler hndl; - SCM inport; - scm_t_port *pt; - - inport = scm_current_input_port (); - if (!SCM_UNBNDP (inport) && SCM_OPINPORTP (inport)) - { - pt = SCM_PTAB_ENTRY (inport); - enc = pt->encoding; - hndl = pt->ilseq_handler; - } - else - { - enc = NULL; - hndl = SCM_FAILED_CONVERSION_ERROR; - } - - return scm_from_stringn (str, len, enc, hndl); + return scm_from_stringn (str, len, locale_charset (), + scm_i_get_conversion_strategy (SCM_BOOL_F)); } SCM @@ -1565,7 +1552,7 @@ scm_from_latin1_stringn (const char *str, size_t len) len = strlen (str); /* Make a narrow string and copy STR as is. */ - result = scm_i_make_string (len, &buf); + result = scm_i_make_string (len, &buf, 0); memcpy (buf, str, len); return result; @@ -1598,7 +1585,7 @@ scm_from_utf32_stringn (const scm_t_wchar *str, size_t len) if (len == (size_t) -1) len = u32_strlen ((uint32_t *) str); - result = scm_i_make_wide_string (len, &buf); + result = scm_i_make_wide_string (len, &buf, 0); memcpy (buf, str, len * sizeof (scm_t_wchar)); scm_i_try_narrow_string (result); @@ -1771,21 +1758,8 @@ scm_to_locale_string (SCM str) char * scm_to_locale_stringn (SCM str, size_t *lenp) { - SCM outport; - scm_t_port *pt; - const char *enc; - - outport = scm_current_output_port (); - if (!SCM_UNBNDP (outport) && SCM_OPOUTPORTP (outport)) - { - pt = SCM_PTAB_ENTRY (outport); - enc = pt->encoding; - } - else - enc = NULL; - return scm_to_stringn (str, lenp, - enc, + locale_charset (), scm_i_get_conversion_strategy (SCM_BOOL_F)); } @@ -2029,7 +2003,7 @@ normalize_str (SCM string, uninorm_t form) w_str = u32_normalize (form, w_str, len, NULL, &rlen); - ret = scm_i_make_wide_string (rlen, &cbuf); + ret = scm_i_make_wide_string (rlen, &cbuf, 0); u32_cpy ((scm_t_uint32 *) cbuf, w_str, rlen); free (w_str); @@ -2241,7 +2215,7 @@ SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string) void scm_init_strings () { - scm_nullstr = scm_i_make_string (0, NULL); + scm_nullstr = scm_i_make_string (0, NULL, 1); #include "libguile/strings.x" } diff --git a/libguile/strings.h b/libguile/strings.h index ed3a067c2..b1fc51a38 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -177,8 +177,11 @@ SCM_API SCM scm_makfromstrs (int argc, char **argv); /* internal accessor functions. Arguments must be valid. */ -SCM_INTERNAL SCM scm_i_make_string (size_t len, char **datap); -SCM_INTERNAL SCM scm_i_make_wide_string (size_t len, scm_t_wchar **datap); +SCM_INTERNAL SCM scm_i_make_string (size_t len, char **datap, + int read_only_p); +SCM_INTERNAL SCM scm_i_make_wide_string (size_t len, scm_t_wchar **datap, + int read_only_p); +SCM_INTERNAL SCM scm_i_set_string_read_only_x (SCM str); SCM_INTERNAL SCM scm_i_substring (SCM str, size_t start, size_t end); SCM_INTERNAL SCM scm_i_substring_read_only (SCM str, size_t start, size_t end); SCM_INTERNAL SCM scm_i_substring_shared (SCM str, size_t start, size_t end); diff --git a/libguile/strports.c b/libguile/strports.c index 625b75308..b7fec4703 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -30,7 +30,7 @@ #include <unistd.h> #endif -#include "libguile/arrays.h" +#include "libguile/bytevectors.h" #include "libguile/eval.h" #include "libguile/ports.h" #include "libguile/read.h" @@ -55,15 +55,8 @@ /* NOTES: - We break the rules set forth by strings.h about accessing the - internals of strings here. We can do this since we can guarantee - that the string used as pt->stream is not in use by anyone else. - Thus, it's representation will not change asynchronously. - - (Ports aren't thread-safe yet anyway...) - - write_buf/write_end point to the ends of the allocated string. - read_buf/read_end in principle point to the part of the string which + write_buf/write_end point to the ends of the allocated bytevector. + read_buf/read_end in principle point to the part of the bytevector which has been written to, but this is only updated after a flush. read_pos and write_pos in principle should be equal, but this is only true when rw_active is SCM_PORT_NEITHER. @@ -106,25 +99,23 @@ stfill_buffer (SCM port) return scm_return_first_int (*pt->read_pos, port); } -/* change the size of a port's string to new_size. this doesn't - change read_buf_size. */ -static void +/* Change the size of a port's bytevector to NEW_SIZE. This doesn't + change `read_buf_size'. */ +static void st_resize_port (scm_t_port *pt, scm_t_off new_size) { SCM old_stream = SCM_PACK (pt->stream); - const char *src = scm_i_string_chars (old_stream); - char *dst; - SCM new_stream = scm_i_make_string (new_size, &dst); - unsigned long int old_size = scm_i_string_length (old_stream); + const signed char *src = SCM_BYTEVECTOR_CONTENTS (old_stream); + SCM new_stream = scm_c_make_bytevector (new_size); + signed char *dst = SCM_BYTEVECTOR_CONTENTS (new_stream); + unsigned long int old_size = SCM_BYTEVECTOR_LENGTH (old_stream); unsigned long int min_size = min (old_size, new_size); - unsigned long int i; scm_t_off index = pt->write_pos - pt->write_buf; pt->write_buf_size = new_size; - for (i = 0; i != min_size; ++i) - dst[i] = src[i]; + memcpy (dst, src, min_size); scm_remember_upto_here_1 (old_stream); @@ -138,27 +129,17 @@ st_resize_port (scm_t_port *pt, scm_t_off new_size) } } -/* amount by which write_buf is expanded. */ -#define SCM_WRITE_BLOCK 80 - -/* ensure that write_pos < write_end by enlarging the buffer when - necessary. update read_buf to account for written chars. - - The buffer is enlarged by 1.5 times, plus SCM_WRITE_BLOCK. Adding just a - fixed amount is no good, because there's a block copy for each increment, - and that copying would take quadratic time. In the past it was found to - be very slow just adding 80 bytes each time (eg. about 10 seconds for - writing a 100kbyte string). */ - +/* Ensure that `write_pos' < `write_end' by enlarging the buffer when + necessary. Update `read_buf' to account for written chars. The + buffer is enlarged geometrically. */ static void st_flush (SCM port) { scm_t_port *pt = SCM_PTAB_ENTRY (port); if (pt->write_pos == pt->write_end) - { - st_resize_port (pt, pt->write_buf_size * 3 / 2 + SCM_WRITE_BLOCK); - } + st_resize_port (pt, pt->write_buf_size * 2); + pt->read_pos = pt->write_pos; if (pt->read_pos > pt->read_end) { @@ -255,12 +236,8 @@ st_seek (SCM port, scm_t_off offset, int whence) SCM_EOL); } } - else - { - st_resize_port (pt, target + (target == pt->write_buf_size - ? SCM_WRITE_BLOCK - : 0)); - } + else if (target == pt->write_buf_size) + st_resize_port (pt, target * 2); } pt->read_pos = pt->write_pos = pt->read_buf + target; if (pt->read_pos > pt->read_end) @@ -289,16 +266,19 @@ st_truncate (SCM port, scm_t_off length) pt->write_pos = pt->read_end; } +/* The initial size in bytes of a string port's buffer. */ +#define INITIAL_BUFFER_SIZE 128 + +/* Return a new string port with MODES. If STR is #f, a new backing + buffer is allocated; otherwise STR must be a string and a copy of it + serves as the buffer for the new port. */ SCM scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) { - SCM z; + SCM z, buf; scm_t_port *pt; size_t str_len, c_pos; - char *buf, *c_str; - - SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller); - c_pos = scm_to_unsigned_integer (pos, 0, scm_i_string_length (str)); + char *c_buf; if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG))) scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL); @@ -308,19 +288,44 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) z = scm_new_port_table_entry (scm_tc16_strport); pt = SCM_PTAB_ENTRY(z); - SCM_SETSTREAM (z, SCM_UNPACK (str)); - SCM_SET_CELL_TYPE (z, scm_tc16_strport | modes); - /* Create a copy of STR in the encoding of Z. */ - buf = scm_to_stringn (str, &str_len, pt->encoding, - SCM_FAILED_CONVERSION_ERROR); - c_str = scm_gc_malloc (str_len, "strport"); - memcpy (c_str, buf, str_len); - free (buf); + if (scm_is_false (str)) + { + /* Allocate a new buffer to write to. */ + str_len = INITIAL_BUFFER_SIZE; + buf = scm_c_make_bytevector (str_len); + c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf); + + /* Reset `read_buf_size'. It will contain the actual number of + bytes written to PT. */ + pt->read_buf_size = 0; + c_pos = 0; + } + else + { + /* STR is a string. */ + char *copy; + + SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller); + + /* Create a copy of STR in the encoding of PT. */ + copy = scm_to_stringn (str, &str_len, pt->encoding, + SCM_FAILED_CONVERSION_ERROR); + buf = scm_c_make_bytevector (str_len); + c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf); + memcpy (c_buf, copy, str_len); + free (copy); - pt->write_buf = pt->read_buf = (unsigned char *) c_str; + c_pos = scm_to_unsigned_integer (pos, 0, str_len); + pt->read_buf_size = str_len; + } + + SCM_SETSTREAM (z, SCM_UNPACK (buf)); + SCM_SET_CELL_TYPE (z, scm_tc16_strport | modes); + + pt->write_buf = pt->read_buf = (unsigned char *) c_buf; pt->read_pos = pt->write_pos = pt->read_buf + c_pos; - pt->write_buf_size = pt->read_buf_size = str_len; + pt->write_buf_size = str_len; pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size; pt->rw_random = 1; @@ -352,7 +357,7 @@ scm_strport_to_string (SCM port) if (pt->encoding == NULL) { char *buf; - str = scm_i_make_string (pt->read_buf_size, &buf); + str = scm_i_make_string (pt->read_buf_size, &buf, 0); memcpy (buf, pt->read_buf, pt->read_buf_size); } else @@ -369,20 +374,30 @@ SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0, "argument @var{printer} (default: @code{write}).") #define FUNC_NAME s_scm_object_to_string { - SCM str, port; + SCM port, result; if (!SCM_UNBNDP (printer)) SCM_VALIDATE_PROC (2, printer); - str = scm_c_make_string (0, SCM_UNDEFINED); - port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, FUNC_NAME); + port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, + SCM_OPN | SCM_WRTNG, FUNC_NAME); if (SCM_UNBNDP (printer)) scm_write (obj, port); else scm_call_2 (printer, obj, port); - return scm_strport_to_string (port); + result = scm_strport_to_string (port); + + /* Explicitly close PORT so that the iconv CDs associated with it are + deallocated right away. This is important because CDs use a lot of + memory that's not visible to the GC, so not freeing them can lead + to almost large heap usage. See + <http://wingolog.org/archives/2011/02/25/ports-weaks-gc-and-dark-matter> + for details. */ + scm_close_port (port); + + return result; } #undef FUNC_NAME @@ -395,8 +410,7 @@ SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0, { SCM p; - p = scm_mkstrport (SCM_INUM0, - scm_make_string (SCM_INUM0, SCM_UNDEFINED), + p = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_OPN | SCM_WRTNG, FUNC_NAME); scm_call_1 (proc, p); @@ -441,8 +455,7 @@ SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0, { SCM p; - p = scm_mkstrport (SCM_INUM0, - scm_make_string (SCM_INUM0, SCM_UNDEFINED), + p = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_OPN | SCM_WRTNG, FUNC_NAME); return p; @@ -467,15 +480,12 @@ SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0, SCM scm_c_read_string (const char *expr) { - /* FIXME: the c string gets packed into a string, only to get - immediately unpacked in scm_mkstrport. */ SCM port = scm_mkstrport (SCM_INUM0, scm_from_locale_string (expr), SCM_OPN | SCM_RDNG, "scm_c_read_string"); SCM form; - /* Read expressions from that port; ignore the values. */ form = scm_read (port); scm_close_port (port); @@ -497,25 +507,6 @@ scm_c_eval_string_in_module (const char *expr, SCM module) } -static SCM -inner_eval_string (void *data) -{ - SCM port = (SCM)data; - SCM form; - SCM ans = SCM_UNSPECIFIED; - - /* Read expressions from that port; ignore the values. */ - while (!SCM_EOF_OBJECT_P (form = scm_read (port))) - ans = scm_primitive_eval_x (form); - - /* Don't close the port here; if we re-enter this function via a - continuation, then the next time we enter it, we'll get an error. - It's a string port anyway, so there's no advantage to closing it - early. */ - - return ans; -} - SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0, (SCM string, SCM module), "Evaluate @var{string} as the text representation of a Scheme\n" @@ -527,14 +518,20 @@ SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0, "procedure returns.") #define FUNC_NAME s_scm_eval_string_in_module { - SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG, - FUNC_NAME); + static SCM eval_string = SCM_BOOL_F, k_module = SCM_BOOL_F; + + if (scm_is_false (eval_string)) + { + eval_string = scm_c_public_lookup ("ice-9 eval-string", "eval-string"); + k_module = scm_from_locale_keyword ("module"); + } + if (SCM_UNBNDP (module)) module = scm_current_module (); else SCM_VALIDATE_MODULE (2, module); - return scm_c_call_with_current_module (module, - inner_eval_string, (void *)port); + + return scm_call_3 (scm_variable_ref (eval_string), string, k_module, module); } #undef FUNC_NAME diff --git a/libguile/symbols.c b/libguile/symbols.c index b9d41b0e2..2a1b46dce 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -1,5 +1,6 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2009 Free Software Foundation, Inc. - * +/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004, + * 2006, 2009, 2011 Free Software Foundation, Inc. + * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License * as published by the Free Software Foundation; either version 3 of @@ -341,6 +342,9 @@ SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, } #undef FUNC_NAME +/* The default prefix for `gensym'd symbols. */ +static SCM default_gensym_prefix; + #define MAX_PREFIX_LENGTH 30 SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, @@ -359,15 +363,15 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, char buf[SCM_INTBUFLEN]; if (SCM_UNBNDP (prefix)) - prefix = scm_from_locale_string (" g"); - + prefix = default_gensym_prefix; + /* mutex in case another thread looks and incs at the exact same moment */ scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); n = gensym_counter++; scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); n_digits = scm_iint2str (n, 10, buf); - suffix = scm_from_locale_stringn (buf, n_digits); + suffix = scm_from_latin1_stringn (buf, n_digits); name = scm_string_append (scm_list_2 (prefix, suffix)); return scm_string_to_symbol (name); } @@ -506,6 +510,8 @@ void scm_init_symbols () { #include "libguile/symbols.x" + + default_gensym_prefix = scm_from_latin1_string (" g"); } /* diff --git a/libguile/threads.c b/libguile/threads.c index e7347ad57..14bda1d2f 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -79,6 +79,122 @@ typedef void * (* GC_fn_type) (void *); #endif +#ifndef GC_SUCCESS +#define GC_SUCCESS 0 +#endif + +#ifndef GC_UNIMPLEMENTED +#define GC_UNIMPLEMENTED 3 +#endif + +/* Likewise struct GC_stack_base is missing before 7.1. */ +#ifndef HAVE_GC_STACK_BASE +struct GC_stack_base { + void * mem_base; /* Base of memory stack. */ +#ifdef __ia64__ + void * reg_base; /* Base of separate register stack. */ +#endif +}; + +static int +GC_register_my_thread (struct GC_stack_base *stack_base) +{ + return GC_UNIMPLEMENTED; +} + +static void +GC_unregister_my_thread () +{ +} + +#if !SCM_USE_PTHREAD_THREADS +/* No threads; we can just use GC_stackbottom. */ +static void * +get_thread_stack_base () +{ + return GC_stackbottom; +} + +#elif defined HAVE_PTHREAD_ATTR_GETSTACK && defined HAVE_PTHREAD_GETATTR_NP \ + && defined PTHREAD_ATTR_GETSTACK_WORKS +/* This method for GNU/Linux and perhaps some other systems. + It's not for MacOS X or Solaris 10, since pthread_getattr_np is not + available on them. */ +static void * +get_thread_stack_base () +{ + pthread_attr_t attr; + void *start, *end; + size_t size; + + pthread_getattr_np (pthread_self (), &attr); + pthread_attr_getstack (&attr, &start, &size); + end = (char *)start + size; + +#if SCM_STACK_GROWS_UP + return start; +#else + return end; +#endif +} + +#elif defined HAVE_PTHREAD_GET_STACKADDR_NP +/* This method for MacOS X. + It'd be nice if there was some documentation on pthread_get_stackaddr_np, + but as of 2006 there's nothing obvious at apple.com. */ +static void * +get_thread_stack_base () +{ + return pthread_get_stackaddr_np (pthread_self ()); +} + +#else +#error Threads enabled with old BDW-GC, but missing get_thread_stack_base impl. Please upgrade to libgc >= 7.1. +#endif + +static int +GC_get_stack_base (struct GC_stack_base *stack_base) +{ + stack_base->mem_base = get_thread_stack_base (); +#ifdef __ia64__ + /* Calculate and store off the base of this thread's register + backing store (RBS). Unfortunately our implementation(s) of + scm_ia64_register_backing_store_base are only reliable for the + main thread. For other threads, therefore, find out the current + top of the RBS, and use that as a maximum. */ + stack_base->reg_base = scm_ia64_register_backing_store_base (); + { + ucontext_t ctx; + void *bsp; + getcontext (&ctx); + bsp = scm_ia64_ar_bsp (&ctx); + if (stack_base->reg_base > bsp) + stack_base->reg_base = bsp; + } +#endif + return GC_SUCCESS; +} + +static void * +GC_call_with_stack_base(void * (*fn) (struct GC_stack_base*, void*), void *arg) +{ + struct GC_stack_base stack_base; + + stack_base.mem_base = (void*)&stack_base; +#ifdef __ia64__ + /* FIXME: Untested. */ + { + ucontext_t ctx; + getcontext (&ctx); + stack_base.reg_base = scm_ia64_ar_bsp (&ctx); + } +#endif + + return fn (&stack_base, arg); +} +#endif /* HAVE_GC_STACK_BASE */ + + /* Now define with_gc_active and with_gc_inactive. */ #if (defined(HAVE_GC_DO_BLOCKING) && defined (HAVE_DECL_GC_DO_BLOCKING) && defined (HAVE_GC_CALL_WITH_GC_ACTIVE)) @@ -343,6 +459,12 @@ unblock_from_queue (SCM queue) /* Getting into and out of guile mode. */ +/* Key used to attach a cleanup handler to a given thread. Also, if + thread-local storage is unavailable, this key is used to retrieve the + current thread with `pthread_getspecific ()'. */ +scm_i_pthread_key_t scm_i_thread_key; + + #ifdef SCM_HAVE_THREAD_STORAGE_CLASS /* When thread-local storage (TLS) is available, a pointer to the @@ -352,17 +474,7 @@ unblock_from_queue (SCM queue) represent. */ SCM_THREAD_LOCAL scm_i_thread *scm_i_current_thread = NULL; -# define SET_CURRENT_THREAD(_t) scm_i_current_thread = (_t) - -#else /* !SCM_HAVE_THREAD_STORAGE_CLASS */ - -/* Key used to retrieve the current thread with `pthread_getspecific ()'. */ -scm_i_pthread_key_t scm_i_thread_key; - -# define SET_CURRENT_THREAD(_t) \ - scm_i_pthread_setspecific (scm_i_thread_key, (_t)) - -#endif /* !SCM_HAVE_THREAD_STORAGE_CLASS */ +#endif /* SCM_HAVE_THREAD_STORAGE_CLASS */ static scm_i_pthread_mutex_t thread_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; @@ -374,67 +486,75 @@ static SCM scm_i_default_dynamic_state; /* Perform first stage of thread initialisation, in non-guile mode. */ static void -guilify_self_1 (SCM_STACKITEM *base) -{ - scm_i_thread *t = scm_gc_malloc (sizeof (scm_i_thread), "thread"); - - t->pthread = scm_i_pthread_self (); - t->handle = SCM_BOOL_F; - t->result = SCM_BOOL_F; - t->cleanup_handler = SCM_BOOL_F; - t->mutexes = SCM_EOL; - t->held_mutex = NULL; - t->join_queue = SCM_EOL; - t->dynamic_state = SCM_BOOL_F; - t->dynwinds = SCM_EOL; - t->active_asyncs = SCM_EOL; - t->block_asyncs = 1; - t->pending_asyncs = 1; - t->critical_section_level = 0; - t->base = base; +guilify_self_1 (struct GC_stack_base *base) +{ + scm_i_thread t; + + /* We must arrange for SCM_I_CURRENT_THREAD to point to a valid value + before allocating anything in this thread, because allocation could + cause GC to run, and GC could cause finalizers, which could invoke + Scheme functions, which need the current thread to be set. */ + + t.pthread = scm_i_pthread_self (); + t.handle = SCM_BOOL_F; + t.result = SCM_BOOL_F; + t.cleanup_handler = SCM_BOOL_F; + t.mutexes = SCM_EOL; + t.held_mutex = NULL; + t.join_queue = SCM_EOL; + t.dynamic_state = SCM_BOOL_F; + t.dynwinds = SCM_EOL; + t.active_asyncs = SCM_EOL; + t.block_asyncs = 1; + t.pending_asyncs = 1; + t.critical_section_level = 0; + t.base = base->mem_base; #ifdef __ia64__ - /* Calculate and store off the base of this thread's register - backing store (RBS). Unfortunately our implementation(s) of - scm_ia64_register_backing_store_base are only reliable for the - main thread. For other threads, therefore, find out the current - top of the RBS, and use that as a maximum. */ - t->register_backing_store_base = scm_ia64_register_backing_store_base (); - { - ucontext_t ctx; - void *bsp; - getcontext (&ctx); - bsp = scm_ia64_ar_bsp (&ctx); - if (t->register_backing_store_base > bsp) - t->register_backing_store_base = bsp; - } + t.register_backing_store_base = base->reg-base; #endif - t->continuation_root = SCM_EOL; - t->continuation_base = base; - scm_i_pthread_cond_init (&t->sleep_cond, NULL); - t->sleep_mutex = NULL; - t->sleep_object = SCM_BOOL_F; - t->sleep_fd = -1; - - if (pipe (t->sleep_pipe) != 0) + t.continuation_root = SCM_EOL; + t.continuation_base = t.base; + scm_i_pthread_cond_init (&t.sleep_cond, NULL); + t.sleep_mutex = NULL; + t.sleep_object = SCM_BOOL_F; + t.sleep_fd = -1; + + if (pipe (t.sleep_pipe) != 0) /* FIXME: Error conditions during the initialization phase are handled gracelessly since public functions such as `scm_init_guile ()' currently have type `void'. */ abort (); - scm_i_pthread_mutex_init (&t->admin_mutex, NULL); - t->current_mark_stack_ptr = NULL; - t->current_mark_stack_limit = NULL; - t->canceled = 0; - t->exited = 0; - t->guile_mode = 0; + scm_i_pthread_mutex_init (&t.admin_mutex, NULL); + t.current_mark_stack_ptr = NULL; + t.current_mark_stack_limit = NULL; + t.canceled = 0; + t.exited = 0; + t.guile_mode = 0; - SET_CURRENT_THREAD (t); + /* The switcheroo. */ + { + scm_i_thread *t_ptr = &t; + + GC_disable (); + t_ptr = GC_malloc (sizeof (scm_i_thread)); + memcpy (t_ptr, &t, sizeof t); - scm_i_pthread_mutex_lock (&thread_admin_mutex); - t->next_thread = all_threads; - all_threads = t; - thread_count++; - scm_i_pthread_mutex_unlock (&thread_admin_mutex); + scm_i_pthread_setspecific (scm_i_thread_key, t_ptr); + +#ifdef SCM_HAVE_THREAD_STORAGE_CLASS + /* Cache the current thread in TLS for faster lookup. */ + scm_i_current_thread = t_ptr; +#endif + + scm_i_pthread_mutex_lock (&thread_admin_mutex); + t_ptr->next_thread = all_threads; + all_threads = t_ptr; + thread_count++; + scm_i_pthread_mutex_unlock (&thread_admin_mutex); + + GC_enable (); + } } /* Perform second stage of thread initialisation, in guile mode. @@ -537,6 +657,15 @@ do_thread_exit (void *v) return NULL; } +static void * +do_thread_exit_trampoline (struct GC_stack_base *sb, void *v) +{ + /* Won't hurt if we are already registered. */ + GC_register_my_thread (sb); + + return scm_with_guile (do_thread_exit, v); +} + static void on_thread_exit (void *v) { @@ -551,19 +680,18 @@ on_thread_exit (void *v) t->held_mutex = NULL; } - SET_CURRENT_THREAD (v); + /* Reinstate the current thread for purposes of scm_with_guile + guile-mode cleanup handlers. Only really needed in the non-TLS + case but it doesn't hurt to be consistent. */ + scm_i_pthread_setspecific (scm_i_thread_key, t); /* Ensure the signal handling thread has been launched, because we might be shutting it down. */ scm_i_ensure_signal_delivery_thread (); - /* Unblocking the joining threads needs to happen in guile mode - since the queue is a SCM data structure. */ - - /* Note: Since `do_thread_exit ()' uses allocates memory via `libgc', we - assume the GC is usable at this point, and notably that thread-local - storage (TLS) hasn't been deallocated yet. */ - do_thread_exit (v); + /* Scheme-level thread finalizers and other cleanup needs to happen in + guile mode. */ + GC_call_with_stack_base (do_thread_exit_trampoline, t); /* Removing ourself from the list of all threads needs to happen in non-guile mode since all SCM values on our stack become @@ -590,21 +718,21 @@ on_thread_exit (void *v) scm_i_pthread_mutex_unlock (&thread_admin_mutex); - SET_CURRENT_THREAD (NULL); -} + scm_i_pthread_setspecific (scm_i_thread_key, NULL); -#ifndef SCM_HAVE_THREAD_STORAGE_CLASS +#if !SCM_USE_NULL_THREADS + GC_unregister_my_thread (); +#endif +} static scm_i_pthread_once_t init_thread_key_once = SCM_I_PTHREAD_ONCE_INIT; static void init_thread_key (void) { - scm_i_pthread_key_create (&scm_i_thread_key, NULL); + scm_i_pthread_key_create (&scm_i_thread_key, on_thread_exit); } -#endif - /* Perform any initializations necessary to make the current thread known to Guile (via SCM_I_CURRENT_THREAD), initializing Guile itself, if necessary. @@ -623,11 +751,9 @@ init_thread_key (void) be sure. New threads are put into guile mode implicitly. */ static int -scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent) +scm_i_init_thread_for_guile (struct GC_stack_base *base, SCM parent) { -#ifndef SCM_HAVE_THREAD_STORAGE_CLASS scm_i_pthread_once (&init_thread_key_once, init_thread_key); -#endif if (SCM_I_CURRENT_THREAD) { @@ -647,6 +773,12 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent) initialization. */ scm_i_init_guile (base); + +#ifdef HAVE_GC_ALLOW_REGISTER_THREADS + /* Allow other threads to come in later. */ + GC_allow_register_threads (); +#endif + scm_i_pthread_mutex_unlock (&scm_i_init_mutex); } else @@ -655,6 +787,10 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent) the first time. Only initialize this thread. */ scm_i_pthread_mutex_unlock (&scm_i_init_mutex); + + /* Register this thread with libgc. */ + GC_register_my_thread (base); + guilify_self_1 (base); guilify_self_2 (parent); } @@ -662,137 +798,58 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent) } } -#if SCM_USE_PTHREAD_THREADS - -#if defined HAVE_PTHREAD_ATTR_GETSTACK && defined HAVE_PTHREAD_GETATTR_NP -/* This method for GNU/Linux and perhaps some other systems. - It's not for MacOS X or Solaris 10, since pthread_getattr_np is not - available on them. */ -#define HAVE_GET_THREAD_STACK_BASE - -static SCM_STACKITEM * -get_thread_stack_base () +void +scm_init_guile () { - pthread_attr_t attr; - void *start, *end; - size_t size; - - pthread_getattr_np (pthread_self (), &attr); - pthread_attr_getstack (&attr, &start, &size); - end = (char *)start + size; - - /* XXX - pthread_getattr_np from LinuxThreads does not seem to work - for the main thread, but we can use scm_get_stack_base in that - case. - */ - -#ifndef PTHREAD_ATTR_GETSTACK_WORKS - if ((void *)&attr < start || (void *)&attr >= end) - return (SCM_STACKITEM *) GC_stackbottom; + struct GC_stack_base stack_base; + + if (GC_get_stack_base (&stack_base) == GC_SUCCESS) + scm_i_init_thread_for_guile (&stack_base, + scm_i_default_dynamic_state); else -#endif { -#if SCM_STACK_GROWS_UP - return start; -#else - return end; -#endif + fprintf (stderr, "Failed to get stack base for current thread.\n"); + exit (1); } } -#elif defined HAVE_PTHREAD_GET_STACKADDR_NP -/* This method for MacOS X. - It'd be nice if there was some documentation on pthread_get_stackaddr_np, - but as of 2006 there's nothing obvious at apple.com. */ -#define HAVE_GET_THREAD_STACK_BASE -static SCM_STACKITEM * -get_thread_stack_base () -{ - return pthread_get_stackaddr_np (pthread_self ()); -} - -#elif defined (__MINGW32__) -/* This method for mingw. In mingw the basic scm_get_stack_base can be used - in any thread. We don't like hard-coding the name of a system, but there - doesn't seem to be a cleaner way of knowing scm_get_stack_base can - work. */ -#define HAVE_GET_THREAD_STACK_BASE -static SCM_STACKITEM * -get_thread_stack_base () -{ - return (SCM_STACKITEM *) GC_stackbottom; -} - -#endif /* pthread methods of get_thread_stack_base */ - -#else /* !SCM_USE_PTHREAD_THREADS */ - -#define HAVE_GET_THREAD_STACK_BASE - -static SCM_STACKITEM * -get_thread_stack_base () -{ - return (SCM_STACKITEM *) GC_stackbottom; -} - -#endif /* !SCM_USE_PTHREAD_THREADS */ - -#ifdef HAVE_GET_THREAD_STACK_BASE - -void -scm_init_guile () -{ - scm_i_init_thread_for_guile (get_thread_stack_base (), - scm_i_default_dynamic_state); -} - -#endif - -void * -scm_with_guile (void *(*func)(void *), void *data) -{ - return scm_i_with_guile_and_parent (func, data, - scm_i_default_dynamic_state); -} - SCM_UNUSED static void scm_leave_guile_cleanup (void *x) { on_thread_exit (SCM_I_CURRENT_THREAD); } -struct with_guile_trampoline_args +struct with_guile_args { GC_fn_type func; void *data; + SCM parent; }; static void * with_guile_trampoline (void *data) { - struct with_guile_trampoline_args *args = data; + struct with_guile_args *args = data; return scm_c_with_continuation_barrier (args->func, args->data); } -void * -scm_i_with_guile_and_parent (void *(*func)(void *), void *data, SCM parent) +static void * +with_guile_and_parent (struct GC_stack_base *base, void *data) { void *res; int new_thread; scm_i_thread *t; - SCM_STACKITEM base_item; + struct with_guile_args *args = data; - new_thread = scm_i_init_thread_for_guile (&base_item, parent); + new_thread = scm_i_init_thread_for_guile (base, args->parent); t = SCM_I_CURRENT_THREAD; if (new_thread) { /* We are in Guile mode. */ assert (t->guile_mode); - scm_i_pthread_cleanup_push (scm_leave_guile_cleanup, NULL); - res = scm_c_with_continuation_barrier (func, data); - scm_i_pthread_cleanup_pop (0); + res = scm_c_with_continuation_barrier (args->func, args->data); /* Leave Guile mode. */ t->guile_mode = 0; @@ -800,14 +857,10 @@ scm_i_with_guile_and_parent (void *(*func)(void *), void *data, SCM parent) else if (t->guile_mode) { /* Already in Guile mode. */ - res = scm_c_with_continuation_barrier (func, data); + res = scm_c_with_continuation_barrier (args->func, args->data); } else { - struct with_guile_trampoline_args args; - args.func = func; - args.data = data; - /* We are not in Guile mode, either because we are not within a scm_with_guile, or because we are within a scm_without_guile. @@ -816,20 +869,39 @@ scm_i_with_guile_and_parent (void *(*func)(void *), void *data, SCM parent) when this thread was first guilified. Thus, `base' must be updated. */ #if SCM_STACK_GROWS_UP - if (SCM_STACK_PTR (&base_item) < t->base) - t->base = SCM_STACK_PTR (&base_item); + if (SCM_STACK_PTR (base->mem_base) < t->base) + t->base = SCM_STACK_PTR (base->mem_base); #else - if (SCM_STACK_PTR (&base_item) > t->base) - t->base = SCM_STACK_PTR (&base_item); + if (SCM_STACK_PTR (base->mem_base) > t->base) + t->base = SCM_STACK_PTR (base->mem_base); #endif t->guile_mode = 1; - res = with_gc_active (with_guile_trampoline, &args); + res = with_gc_active (with_guile_trampoline, args); t->guile_mode = 0; } return res; } +static void * +scm_i_with_guile_and_parent (void *(*func)(void *), void *data, SCM parent) +{ + struct with_guile_args args; + + args.func = func; + args.data = data; + args.parent = parent; + + return GC_call_with_stack_base (with_guile_and_parent, &args); +} + +void * +scm_with_guile (void *(*func)(void *), void *data) +{ + return scm_i_with_guile_and_parent (func, data, + scm_i_default_dynamic_state); +} + void * scm_without_guile (void *(*func)(void *), void *data) { @@ -880,9 +952,6 @@ really_launch (void *d) else t->result = scm_catch (SCM_BOOL_T, thunk, handler); - /* Trigger a call to `on_thread_exit ()'. */ - pthread_exit (NULL); - return 0; } @@ -1965,7 +2034,7 @@ pthread_mutexattr_t scm_i_pthread_mutexattr_recursive[1]; #endif void -scm_threads_prehistory (SCM_STACKITEM *base) +scm_threads_prehistory (void *base) { #if SCM_USE_PTHREAD_THREADS pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive); @@ -1978,7 +2047,7 @@ scm_threads_prehistory (SCM_STACKITEM *base) scm_i_pthread_mutex_init (&scm_i_misc_mutex, NULL); scm_i_pthread_cond_init (&wake_up_cond, NULL); - guilify_self_1 (base); + guilify_self_1 ((struct GC_stack_base *) base); } scm_t_bits scm_tc16_thread; diff --git a/libguile/threads.h b/libguile/threads.h index b5e3c2153..9e44684e1 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -136,13 +136,7 @@ SCM_API SCM scm_spawn_thread (scm_t_catch_body body, void *body_data, SCM_API void *scm_without_guile (void *(*func)(void *), void *data); SCM_API void *scm_with_guile (void *(*func)(void *), void *data); -SCM_INTERNAL void *scm_i_with_guile_and_parent (void *(*func)(void *), - void *data, SCM parent); - - -void scm_threads_prehistory (SCM_STACKITEM *); -void scm_threads_init_first_thread (void); - +SCM_INTERNAL void scm_threads_prehistory (void *); SCM_INTERNAL void scm_init_threads (void); SCM_INTERNAL void scm_init_thread_procs (void); SCM_INTERNAL void scm_init_threads_default_dynamic_state (void); @@ -192,6 +186,10 @@ SCM_API void scm_dynwind_critical_section (SCM mutex); #ifdef BUILDING_LIBGUILE +/* Though we don't need the key for SCM_I_CURRENT_THREAD if we have TLS, + we do use it for cleanup purposes. */ +SCM_INTERNAL scm_i_pthread_key_t scm_i_thread_key; + # ifdef SCM_HAVE_THREAD_STORAGE_CLASS SCM_INTERNAL SCM_THREAD_LOCAL scm_i_thread *scm_i_current_thread; @@ -199,7 +197,6 @@ SCM_INTERNAL SCM_THREAD_LOCAL scm_i_thread *scm_i_current_thread; # else /* !SCM_HAVE_THREAD_STORAGE_CLASS */ -SCM_INTERNAL scm_i_pthread_key_t scm_i_thread_key; # define SCM_I_CURRENT_THREAD \ ((scm_i_thread *) scm_i_pthread_getspecific (scm_i_thread_key)) diff --git a/libguile/throw.c b/libguile/throw.c index 750e6a286..9c293516d 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -467,7 +467,7 @@ pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler) if (SCM_PROMPT_SETJMP (prompt)) { /* nonlocal exit */ - SCM args = scm_i_prompt_pop_abort_args_x (prompt); + SCM args = scm_i_prompt_pop_abort_args_x (vm); /* cdr past the continuation */ return scm_apply_0 (handler, scm_cdr (args)); } diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 20d9ed2c8..4b0ca3ec3 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -93,7 +93,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs) fp = sp + 1; ip = SCM_C_OBJCODE_BASE (bp); /* MV-call frame, function & arguments */ - PUSH ((SCM)fp); /* dynamic link */ + PUSH (0); /* dynamic link */ PUSH (0); /* mvra */ PUSH (0); /* ra */ PUSH (prog); diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c index fae39fb8d..0d8678485 100644 --- a/libguile/vm-i-loader.c +++ b/libguile/vm-i-loader.c @@ -40,7 +40,7 @@ VM_DEFINE_LOADER (102, load_string, "load-string") FETCH_LENGTH (len); SYNC_REGISTER (); - PUSH (scm_i_make_string (len, &buf)); + PUSH (scm_i_make_string (len, &buf, 1)); memcpy (buf, (char *) ip, len); ip += len; NEXT; @@ -113,7 +113,7 @@ VM_DEFINE_LOADER (107, load_wide_string, "load-wide-string") } SYNC_REGISTER (); - PUSH (scm_i_make_wide_string (len / 4, &wbuf)); + PUSH (scm_i_make_wide_string (len / 4, &wbuf, 1)); memcpy ((char *) wbuf, (char *) ip, len); ip += len; NEXT; diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 19b48c59e..9e249bc85 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -821,6 +821,7 @@ BV_FLOAT_REF (f64, ieee_double, double, 8) goto VM_LABEL (bv_##stem##_native_set); \ { \ SCM bv, idx, val; POP (val); POP (idx); POP (bv); \ + SYNC_REGISTER (); \ scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness); \ NEXT; \ } \ @@ -865,7 +866,10 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) && (j <= max))) \ *int_ptr = (scm_t_ ## type) j; \ else \ - scm_bytevector_ ## fn_stem ## _set_x (bv, idx, val); \ + { \ + SYNC_REGISTER (); \ + scm_bytevector_ ## fn_stem ## _set_x (bv, idx, val); \ + } \ NEXT; \ } @@ -886,29 +890,35 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \ *int_ptr = scm_to_ ## type (val); \ else \ - scm_bytevector_ ## stem ## _native_set_x (bv, idx, val); \ - NEXT; \ + { \ + SYNC_REGISTER (); \ + scm_bytevector_ ## stem ## _native_set_x (bv, idx, val); \ + } \ + NEXT; \ } -#define BV_FLOAT_SET(stem, fn_stem, type, size) \ -{ \ - scm_t_signed_bits i = 0; \ - SCM bv, idx, val; \ - type *float_ptr; \ - \ - POP (val); POP (idx); POP (bv); \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \ - i = SCM_I_INUM (idx); \ - float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (float_ptr, type)))) \ - *float_ptr = scm_to_double (val); \ - else \ - scm_bytevector_ ## fn_stem ## _native_set_x (bv, idx, val); \ - NEXT; \ +#define BV_FLOAT_SET(stem, fn_stem, type, size) \ +{ \ + scm_t_signed_bits i = 0; \ + SCM bv, idx, val; \ + type *float_ptr; \ + \ + POP (val); POP (idx); POP (bv); \ + VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \ + i = SCM_I_INUM (idx); \ + float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ + \ + if (SCM_LIKELY (SCM_I_INUMP (idx) \ + && (i >= 0) \ + && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ + && (ALIGNED_P (float_ptr, type)))) \ + *float_ptr = scm_to_double (val); \ + else \ + { \ + SYNC_REGISTER (); \ + scm_bytevector_ ## fn_stem ## _native_set_x (bv, idx, val); \ + } \ + NEXT; \ } VM_DEFINE_INSTRUCTION (200, bv_u8_set, "bv-u8-set", 0, 3, 0) diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 57712cabd..71c5281c8 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -756,9 +756,14 @@ VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3) { /* NB: if you change this, see frames.c:vm-frame-num-locals */ /* and frames.h, vm-engine.c, etc of course */ - PUSH ((SCM)fp); /* dynamic link */ - PUSH (0); /* mvra */ - PUSH (0); /* ra */ + + /* We don't initialize the dynamic link here because we don't actually + know that this frame will point to the current fp: it could be + placed elsewhere on the stack if captured in a partial + continuation, and invoked from some other context. */ + PUSH (0); /* dynamic link */ + PUSH (0); /* mvra */ + PUSH (0); /* ra */ NEXT; } @@ -790,11 +795,20 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1) } CACHE_PROGRAM (); - fp = sp - nargs + 1; - ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); - ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); - SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); - SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0); + + { + SCM *old_fp = fp; + + fp = sp - nargs + 1; + + ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0); + ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); + ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); + SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); + SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); + SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0); + } + ip = SCM_C_OBJCODE_BASE (bp); PUSH_CONTINUATION_HOOK (); APPLY_HOOK (); @@ -1091,11 +1105,20 @@ VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1) } CACHE_PROGRAM (); - fp = sp - nargs + 1; - ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); - ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); - SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); - SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra); + + { + SCM *old_fp = fp; + + fp = sp - nargs + 1; + + ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0); + ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); + ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); + SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); + SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); + SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra); + } + ip = SCM_C_OBJCODE_BASE (bp); PUSH_CONTINUATION_HOOK (); APPLY_HOOK (); @@ -1156,7 +1179,7 @@ VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1) cont = scm_i_make_continuation (&first, vm, vm_cont); if (first) { - PUSH ((SCM)fp); /* dynamic link */ + PUSH (0); /* dynamic link */ PUSH (0); /* mvra */ PUSH (0); /* ra */ PUSH (proc); |