summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-rw-r--r--libguile/debug.c13
-rw-r--r--libguile/debug.h4
-rw-r--r--libguile/eval.c46
-rw-r--r--libguile/eval.h7
-rw-r--r--libguile/gc.c4
-rw-r--r--libguile/i18n.c3
-rw-r--r--libguile/macros.c34
-rw-r--r--libguile/symbols.c50
-rw-r--r--libguile/threads.c1
-rw-r--r--libguile/threads.h4
-rw-r--r--libguile/vm-i-system.c25
11 files changed, 124 insertions, 67 deletions
diff --git a/libguile/debug.c b/libguile/debug.c
index c6ce99e7c..87513bf48 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -1,5 +1,5 @@
/* Debugging extensions for Guile
- * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -199,6 +199,17 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
#undef FUNC_NAME
#endif
+SCM
+scm_local_eval (SCM exp, SCM env)
+{
+ static SCM local_eval_var = SCM_BOOL_F;
+
+ if (scm_is_false (local_eval_var))
+ local_eval_var = scm_c_public_variable ("ice-9 local-eval", "local-eval");
+
+ return scm_call_2 (SCM_VARIABLE_REF (local_eval_var), exp, env);
+}
+
static void
init_stack_limit (void)
{
diff --git a/libguile/debug.h b/libguile/debug.h
index 0749d283c..362d9b7e2 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -3,7 +3,7 @@
#ifndef SCM_DEBUG_H
#define SCM_DEBUG_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2012
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -41,6 +41,8 @@ typedef union scm_t_debug_info
+SCM_API SCM scm_local_eval (SCM exp, SCM env);
+
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
SCM_API SCM scm_procedure_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc);
diff --git a/libguile/eval.c b/libguile/eval.c
index ad0a84a58..5a42b1ead 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -24,6 +24,7 @@
#endif
#include <alloca.h>
+#include <stdarg.h>
#include "libguile/__scm.h"
@@ -521,11 +522,56 @@ scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
}
SCM
+scm_call_7 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
+ SCM arg6, SCM arg7)
+{
+ SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 7);
+}
+
+SCM
+scm_call_8 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
+ SCM arg6, SCM arg7, SCM arg8)
+{
+ SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 8);
+}
+
+SCM
+scm_call_9 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
+ SCM arg6, SCM arg7, SCM arg8, SCM arg9)
+{
+ SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 9);
+}
+
+SCM
scm_call_n (SCM proc, SCM *argv, size_t nargs)
{
return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
}
+SCM
+scm_call (SCM proc, ...)
+{
+ va_list argp;
+ SCM *argv = NULL;
+ size_t i, nargs = 0;
+
+ va_start (argp, proc);
+ while (!SCM_UNBNDP (va_arg (argp, SCM)))
+ nargs++;
+ va_end (argp);
+
+ argv = alloca (nargs * sizeof (SCM));
+ va_start (argp, proc);
+ for (i = 0; i < nargs; i++)
+ argv[i] = va_arg (argp, SCM);
+ va_end (argp);
+
+ return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
+}
+
/* Simple procedure applies
*/
diff --git a/libguile/eval.h b/libguile/eval.h
index f193ad64e..014f0dec5 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -72,7 +72,14 @@ 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_7 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
+ SCM arg5, SCM arg6, SCM arg7);
+SCM_API SCM scm_call_8 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
+ SCM arg5, SCM arg6, SCM arg7, SCM arg8);
+SCM_API SCM scm_call_9 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
+ SCM arg5, SCM arg6, SCM arg7, SCM arg8, SCM arg9);
SCM_API SCM scm_call_n (SCM proc, SCM *argv, size_t nargs);
+SCM_API SCM scm_call (SCM proc, ...);
SCM_API SCM scm_apply_0 (SCM proc, SCM args);
SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args);
diff --git a/libguile/gc.c b/libguile/gc.c
index 5f61a1de8..6d44f5e38 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -227,6 +227,10 @@ scm_t_c_hook scm_after_gc_c_hook;
static void
run_before_gc_c_hook (void)
{
+ if (!SCM_I_CURRENT_THREAD)
+ /* GC while a thread is spinning up; punt. */
+ return;
+
scm_c_hook_run (&scm_before_gc_c_hook, NULL);
}
diff --git a/libguile/i18n.c b/libguile/i18n.c
index 4bb9e2137..5a53bfae5 100644
--- a/libguile/i18n.c
+++ b/libguile/i18n.c
@@ -645,6 +645,7 @@ SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale);
free (c_locale_name);
+ c_locale_name = NULL;
if (c_locale == (locale_t) 0)
{
@@ -662,6 +663,7 @@ SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
c_locale->category_mask = c_category_mask;
c_locale->locale_name = scm_gc_strdup (c_locale_name, "locale");
free (c_locale_name);
+ c_locale_name = NULL;
if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
{
@@ -1652,6 +1654,7 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
default:
result = scm_from_latin1_symbol ("unspecified");
}
+ free (c_result);
break;
#endif
diff --git a/libguile/macros.c b/libguile/macros.c
index 7423e9758..34aa60c83 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -177,12 +177,46 @@ SCM_DEFINE (scm_macro_binding, "macro-binding", 1, 0, 0,
#undef FUNC_NAME
+static SCM syntax_session_id;
+
+#define SESSION_ID_LENGTH 22 /* bytes */
+#define BASE64_RADIX_BITS 6
+#define BASE64_RADIX (1 << (BASE64_RADIX_BITS))
+#define BASE64_MASK (BASE64_RADIX - 1)
+
+static SCM
+fresh_syntax_session_id (void)
+{
+ static const char base64[BASE64_RADIX] =
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789$@";
+
+ unsigned char digit_buf[SESSION_ID_LENGTH];
+ char char_buf[SESSION_ID_LENGTH];
+ size_t i;
+
+ scm_i_random_bytes_from_platform (digit_buf, SESSION_ID_LENGTH);
+ for (i = 0; i < SESSION_ID_LENGTH; ++i)
+ char_buf[i] = base64[digit_buf[i] & BASE64_MASK];
+
+ return scm_from_latin1_stringn (char_buf, SESSION_ID_LENGTH);
+}
+
+static SCM
+scm_syntax_session_id (void)
+{
+ return syntax_session_id;
+}
+
+
void
scm_init_macros ()
{
scm_tc16_macro = scm_make_smob_type ("macro", 0);
scm_set_smob_print (scm_tc16_macro, macro_print);
#include "libguile/macros.x"
+
+ syntax_session_id = fresh_syntax_session_id();
+ scm_c_define_gsubr ("syntax-session-id", 0, 0, 0, scm_syntax_session_id);
}
/*
diff --git a/libguile/symbols.c b/libguile/symbols.c
index 9dd204478..9cb300ab0 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -33,7 +33,6 @@
#include "libguile/variable.h"
#include "libguile/alist.h"
#include "libguile/fluids.h"
-#include "libguile/threads.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/weak-set.h"
@@ -379,9 +378,7 @@ SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0,
/* The default prefix for `gensym'd symbols. */
static SCM default_gensym_prefix;
-#define GENSYM_LENGTH 22 /* bytes */
-#define GENSYM_RADIX_BITS 6
-#define GENSYM_RADIX (1 << (GENSYM_RADIX_BITS))
+#define MAX_PREFIX_LENGTH 30
SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
(SCM prefix),
@@ -392,47 +389,22 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
"resetting the counter.")
#define FUNC_NAME s_scm_gensym
{
- static const char base64[GENSYM_RADIX] =
- "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789$@";
- static const char base4[4] = "_.-~";
-
- unsigned char *digit_buf = SCM_I_CURRENT_THREAD->gensym_counter;
- char char_buf[GENSYM_LENGTH];
+ static int gensym_counter = 0;
+
SCM suffix, name;
- int i;
+ int n, n_digits;
+ char buf[SCM_INTBUFLEN];
if (SCM_UNBNDP (prefix))
prefix = default_gensym_prefix;
- if (SCM_UNLIKELY (digit_buf == NULL))
- {
- /* This is the first time gensym has been called in this thread.
- Allocate and randomize our new thread-local gensym counter */
- digit_buf = (unsigned char *)
- scm_gc_malloc_pointerless (GENSYM_LENGTH, "gensym-counter");
- scm_i_random_bytes_from_platform (digit_buf, GENSYM_LENGTH);
- for (i = (GENSYM_LENGTH - 1); i >= 0; --i)
- digit_buf[i] &= (GENSYM_RADIX - 1);
- SCM_I_CURRENT_THREAD->gensym_counter = digit_buf;
- }
-
- /* Increment our thread-local gensym_counter. */
- for (i = (GENSYM_LENGTH - 1); i >= 0; --i)
- {
- if (SCM_LIKELY (++(digit_buf[i]) < GENSYM_RADIX))
- break;
- else
- digit_buf[i] = 0;
- }
-
- /* Encode digit_buf as base64, except for the first character where we
- use the sparse glyphs "_.-~" (base 4) to provide some visual
- separation between the prefix and the dense base64 block. */
- for (i = (GENSYM_LENGTH - 1); i > 0; --i)
- char_buf[i] = base64[digit_buf[i]];
- char_buf[0] = base4[digit_buf[0] & 3];
+ /* 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);
- suffix = scm_from_latin1_stringn (char_buf, GENSYM_LENGTH);
+ n_digits = scm_iint2str (n, 10, buf);
+ suffix = scm_from_latin1_stringn (buf, n_digits);
name = scm_string_append (scm_list_2 (prefix, suffix));
return scm_string_to_symbol (name);
}
diff --git a/libguile/threads.c b/libguile/threads.c
index df287b1ac..463414f4a 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -544,7 +544,6 @@ guilify_self_1 (struct GC_stack_base *base)
t.join_queue = SCM_EOL;
t.dynamic_state = SCM_BOOL_F;
t.dynwinds = SCM_EOL;
- t.gensym_counter = NULL;
t.active_asyncs = SCM_EOL;
t.block_asyncs = 1;
t.pending_asyncs = 1;
diff --git a/libguile/threads.h b/libguile/threads.h
index 2d2348bde..54d64141b 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -81,10 +81,6 @@ typedef struct scm_i_thread {
SCM dynamic_state;
SCM dynwinds;
- /* Thread-local gensym counter.
- */
- unsigned char *gensym_counter;
-
/* For system asyncs.
*/
SCM active_asyncs; /* The thunks to be run at the next
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 0804bad5d..8981042f8 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1,6 +1,5 @@
-/* Copyright (C) 2001, 2008, 2009, 2010, 2011,
- * 2012 Free Software Foundation, Inc.
- *
+/* Copyright (C) 2001,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
* as published by the Free Software Foundation; either version 3 of
@@ -20,17 +19,6 @@
/* This file is included in vm_engine.c */
-/* Compiler barrier, to prevent instruction reordering, apparently due
- to a bug in GCC 4.3.2 on sparc-linux-gnu and on hppa2.0-linux-gnu.
- See <http://bugs.gnu.org/10520>, for details. */
-
-#ifdef __GNUC__
-# define COMPILER_BARRIER __asm__ __volatile__ ("")
-#else
-# define COMPILER_BARRIER do { } while (0)
-#endif
-
-
/*
* Basic operations
@@ -67,7 +55,6 @@ VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
stack */
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- COMPILER_BARRIER;
NULLSTACK (old_sp - sp);
}
@@ -1280,7 +1267,6 @@ VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
sp = SCM_FRAME_LOWER_ADDRESS (fp);
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- COMPILER_BARRIER;
#ifdef VM_ENABLE_STACK_NULLING
NULLSTACK (old_sp - sp);
@@ -1316,8 +1302,7 @@ VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- COMPILER_BARRIER;
-
+
/* Push return values, and the number of values */
for (i = 0; i < nvalues; i++)
*++sp = vals[i+1];
@@ -1337,8 +1322,7 @@ VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- COMPILER_BARRIER;
-
+
/* Push first value */
*++sp = vals[1];
@@ -1729,7 +1713,6 @@ VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1,
NEXT;
}
-#undef COMPILER_BARRIER
/*
(defun renumber-ops ()