mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-19 18:20:22 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
Conflicts:
	libguile/debug.h
	module/ice-9/psyntax-pp.scm
	module/ice-9/psyntax.scm
	module/language/tree-il/peval.scm
	module/language/tree-il/primitives.scm
This commit is contained in:
Andy Wingo 2012-01-30 19:59:08 +01:00
commit dfadcf85cb
45 changed files with 20479 additions and 19006 deletions
Download patch file Download diff file Expand all files Collapse all files

13
libguile/debug.c
View file

@ -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)
{

4
libguile/debug.h
View file

@ -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);

46
libguile/eval.c
View file

@ -24,6 +24,7 @@
#endif
#include <alloca.h>
#include <stdarg.h>
#include "libguile/__scm.h"
@ -520,12 +521,57 @@ scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
return scm_c_vm_run (scm_the_vm (), proc, args, 6);
}
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
*/

7
libguile/eval.h
View file

@ -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);

4
libguile/gc.c
View file

@ -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);
}

3
libguile/i18n.c
View file

@ -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

34
libguile/macros.c
View file

@ -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);
}
/*

50
libguile/symbols.c
View file

@ -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;
}
/* 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);
/* 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];
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);
}

1
libguile/threads.c
View file

@ -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;

4
libguile/threads.h
View file

@ -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

25
libguile/vm-i-system.c
View file

@ -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 ()