LIBS="$BDW_GC_LIBS $LIBS"
CFLAGS="$BDW_GC_CFLAGS $CFLAGS"
- AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap GC_get_unmapped_bytes GC_set_finalizer_notifier GC_set_finalize_on_demand])
+ AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit \
+ GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask \
- GC_set_start_callback GC_get_heap_usage_safe \
- GC_get_free_space_divisor GC_gcollect_and_unmap GC_get_unmapped_bytes \
- GC_set_finalizer_notifier GC_set_finalize_on_demand \
- GC_set_all_interior_pointers GC_get_gc_no GC_set_java_finalization])
++ GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link \
++ GC_get_heap_usage_safe GC_get_free_space_divisor \
++ GC_gcollect_and_unmap GC_get_unmapped_bytes GC_set_finalizer_notifier \
++ GC_set_finalize_on_demand GC_set_all_interior_pointers GC_get_gc_no \
++ GC_set_java_finalization])
# Though the `GC_do_blocking ()' symbol is present in GC 7.1, it is not
# declared, and has a different type (returning void instead of
module/Makefile
])
-AC_CONFIG_FILES([meta/guile-2.0.pc])
-AC_CONFIG_FILES([meta/guile-2.0-uninstalled.pc])
+AC_CONFIG_FILES([meta/guile-2.2.pc])
+AC_CONFIG_FILES([meta/guile-2.2-uninstalled.pc])
- AC_CONFIG_FILES([doc/ref/effective-version.texi])
GUILE_CONFIG_SCRIPT([check-guile])
GUILE_CONFIG_SCRIPT([benchmark-guile])
@deffn {Scheme Procedure} objcode? obj
@deffnx {C Function} scm_objcode_p (obj)
- Returns @code{#f} iff @var{obj} is object code, @code{#f} otherwise.
+ Returns @code{#f} if @var{obj} is object code, @code{#f} otherwise.
@end deffn
-@deffn {Scheme Procedure} bytecode->objcode bytecode
+@deffn {Scheme Procedure} bytecode->objcode bytecode [endianness]
@deffnx {C Function} scm_bytecode_to_objcode (bytecode)
Makes a bytecode object from @var{bytecode}, which should be a
-bytevector. @xref{Bytevectors}.
+bytevector. @xref{Bytevectors}. By default, the embedded length fields
+in the bytevector are interpreted in the native byte order.
@end deffn
-@deffn {Scheme Variable} load-objcode file
-@deffnx {C Function} scm_load_objcode (file)
+@deffn {Scheme Variable} load-thunk-from-file file
+@deffnx {C Function} scm_load_thunk_from_file (file)
Load object code from a file named @var{file}. The file will be mapped
into memory via @code{mmap}, so this is a very fast operation.
You can specify a different history file by setting this environment
variable. By default, the history file is @file{$HOME/.guile_history}.
-characters. However, for compatibility with previous Guile 2.0
-releases, this option is off by default. The next stable release series
-of Guile (the 2.2 series) will install locales by default.
+ @item GUILE_INSTALL_LOCALE
+ @vindex GUILE_INSTALL_LOCALE
+ This is a flag that can be used to tell Guile whether or not to install
+ the current locale at startup, via a call to @code{(setlocale LC_ALL
+ "")}. @xref{Locales}, for more information on locales.
+
+ You may explicitly indicate that you do not want to install
+ the locale by setting @env{GUILE_INSTALL_LOCALE} to @code{0}, or
+ explicitly enable it by setting the variable to @code{1}.
+
+ Usually, installing the current locale is the right thing to do. It
+ allows Guile to correctly parse and print strings with non-ASCII
++characters. Therefore, this option is on by default.
+
+ @item GUILE_STACK_SIZE
+ @vindex GUILE_STACK_SIZE
+ Guile currently has a limited stack size for Scheme computations.
+ Attempting to call too many nested functions will signal an error. This
+ is good to detect infinite recursion, but sometimes the limit is reached
+ for normal computations. This environment variable, if set to a
+ positive integer, specifies the number of Scheme value slots to allocate
+ for the stack.
+
+ In the future we will implement stacks that can grow and shrink, but for
+ now this hack will have to do.
+
@item GUILE_LOAD_COMPILED_PATH
@vindex GUILE_LOAD_COMPILED_PATH
This variable may be used to augment the path that is searched for
/* readline.c --- line editing support for Guile */
--/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008, 2009, 2010, 2013 Free Software Foundation, Inc.
++/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008,
++ * 2009, 2010, 2013 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
## Perhaps we can deal with them normally once the merge seems to be
## working.
noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
+ elf.h \
srfi-14.i.c \
quicksort.i.c \
- win32-uname.h win32-socket.h \
+ win32-uname.h \
private-gc.h private-options.h
# vm instructions
#ifndef SCM_FILESYS_H
#define SCM_FILESYS_H
- /* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ /* Copyright (C) 1995, 1997, 1998, 1999, 2000, 2001, 2006, 2008, 2009,
- * 2010, 2013 Free Software Foundation, Inc.
++ * 2010, 2011, 2013 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
return scm_call_0 (SCM_PACK (thunk));
}
-SCM
-scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals)
+size_t
+scm_prepare_fluids (size_t n, SCM *fluids, SCM *values)
{
- size_t j = n;
- SCM ret;
++ size_t j;
/* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
but N will usually be small, so perhaps that's OK. */
- while (j--)
- {
- size_t i, j;
++ for (j = n; j--;)
+ {
+ size_t i;
+
+ if (SCM_UNLIKELY (!IS_FLUID (fluids[j])))
+ scm_wrong_type_arg ("with-fluids", 0, fluids[j]);
- for (i = 0; i < j; i++)
- for (j = n; j--;)
+ for (i = j; i--;)
if (scm_is_eq (fluids[i], fluids[j]))
{
- vals[i] = vals[j]; /* later bindings win */
+ values[i] = values[j]; /* later bindings win */
n--;
- vals[j] = vals[n];
+ fluids[j] = fluids[n];
++ values[j] = values[n];
break;
}
- }
-
- ret = scm_words (scm_tc7_with_fluids | (n << 8), 1 + n*2);
- SCM_SET_CELL_WORD_1 (ret, n);
-
- while (n--)
- {
- if (SCM_UNLIKELY (!IS_FLUID (fluids[n])))
- scm_wrong_type_arg ("with-fluids", 0, fluids[n]);
- SCM_SET_CELL_OBJECT (ret, 1 + n * 2, fluids[n]);
- SCM_SET_CELL_OBJECT (ret, 2 + n * 2, vals[n]);
}
- return ret;
+ return n;
}
void
}
};
- #undef CODE
+ static SCM
+ make_objcode_trampoline (unsigned int nargs)
+ {
+ const int size = sizeof (struct scm_objcode) + 8
+ + sizeof (struct scm_objcode) + 32;
+ SCM bytecode = scm_c_make_bytevector (size);
+ scm_t_uint8 *bytes = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bytecode);
+ int i = 0;
+
+ #define M_DYNAMIC(x) (bytes[i++] = (x))
+ GEN_CODE (M_DYNAMIC, nargs);
+ #undef M_DYNAMIC
+
+ if (i != size)
+ scm_syserror ("make_objcode_trampoline");
- return scm_bytecode_to_native_objcode (bytecode);
++ return scm_bytecode_to_objcode (bytecode, SCM_UNDEFINED);
+ }
+
+ #undef GEN_CODE
#undef META
+ #undef M_STATIC
+ #undef CODE
#undef OBJCODE_HEADER
#undef META_HEADER
#define FUNC_NAME "scm_fdes_to_port"
{
SCM port;
- scm_t_port *pt;
+ scm_t_fport *fp;
- int flags;
- /* test that fdes is valid. */
- #ifdef __MINGW32__
- flags = getflags (fdes);
- #else
- flags = fcntl (fdes, F_GETFL, 0);
- #endif
+ /* Test that fdes is valid. */
+ #ifdef F_GETFL
+ int flags = fcntl (fdes, F_GETFL, 0);
if (flags == -1)
SCM_SYSERROR;
flags &= O_ACCMODE;
{
SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
}
+ #else
+ /* If we don't have F_GETFL, as on mingw, at least we can test that
+ it is a valid file descriptor. */
+ struct stat st;
+ if (fstat (fdes, &st) != 0)
+ SCM_SYSERROR;
+ #endif
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ fp = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport),
+ "file port");
+ fp->fdes = fdes;
+
+ port = scm_c_make_port (scm_tc16_fport, mode_bits, (scm_t_bits)fp);
+
+ SCM_PTAB_ENTRY (port)->rw_random = SCM_FDES_RANDOM_P (fdes);
+
+ if (mode_bits & SCM_BUF0)
+ scm_fport_buffer_add (port, 0, 0);
+ else
+ scm_fport_buffer_add (port, -1, -1);
- port = scm_new_port_table_entry (scm_tc16_fport);
- SCM_SET_CELL_TYPE(port, scm_tc16_fport | mode_bits);
- pt = SCM_PTAB_ENTRY(port);
- {
- scm_t_fport *fp
- = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport),
- "file port");
-
- fp->fdes = fdes;
- pt->rw_random = SCM_FDES_RANDOM_P (fdes);
- SCM_SETSTREAM (port, fp);
- if (mode_bits & SCM_BUF0)
- scm_fport_buffer_add (port, 0, 0);
- else
- scm_fport_buffer_add (port, -1, -1);
- }
SCM_SET_FILENAME (port, name);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
return port;
}
#undef FUNC_NAME
scm_syserror ("fport_input_waiting");
return pollfd.revents & POLLIN ? 1 : 0;
-
- #elif defined(HAVE_SELECT)
- struct timeval timeout;
- SELECT_TYPE read_set;
- SELECT_TYPE write_set;
- SELECT_TYPE except_set;
-
- FD_ZERO (&read_set);
- FD_ZERO (&write_set);
- FD_ZERO (&except_set);
-
- FD_SET (fdes, &read_set);
-
- timeout.tv_sec = 0;
- timeout.tv_usec = 0;
-
- if (select (SELECT_SET_SIZE,
- &read_set, &write_set, &except_set, &timeout)
- < 0)
- scm_syserror ("fport_input_waiting");
- return FD_ISSET (fdes, &read_set) ? 1 : 0;
-
- #elif HAVE_IOCTL && defined (FIONREAD)
- /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
- (for use with winsock ioctlsocket()) but not ioctl(). */
- int fdes = SCM_FSTREAM (port)->fdes;
- int remir;
- ioctl(fdes, FIONREAD, &remir);
- return remir;
-
- #else
- scm_misc_error ("fport_input_waiting",
- "Not fully implemented on this platform",
- SCM_EOL);
- #endif
}
+
+\f
+
+/* Revealed counts --- an oddity inherited from SCSH. */
+
+#define SCM_REVEALED(x) (SCM_FSTREAM(x)->revealed)
+
+static SCM revealed_ports = SCM_EOL;
+static scm_i_pthread_mutex_t revealed_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+/* Find a port in the table and return its revealed count.
+ Also used by the garbage collector.
+ */
+int
+scm_revealed_count (SCM port)
+{
+ int ret;
+
+ scm_i_pthread_mutex_lock (&revealed_lock);
+ ret = SCM_REVEALED (port);
+ scm_i_pthread_mutex_unlock (&revealed_lock);
+
+ return ret;
+}
+
+SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
+ (SCM port),
+ "Return the revealed count for @var{port}.")
+#define FUNC_NAME s_scm_port_revealed
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPFPORT (1, port);
+ return scm_from_int (scm_revealed_count (port));
+}
+#undef FUNC_NAME
+
+/* Set the revealed count for a port. */
+SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
+ (SCM port, SCM rcount),
+ "Sets the revealed count for a port to a given value.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_set_port_revealed_x
+{
+ int r, prev;
+
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPFPORT (1, port);
+
+ r = scm_to_int (rcount);
+
+ scm_i_pthread_mutex_lock (&revealed_lock);
+
+ prev = SCM_REVEALED (port);
+ SCM_REVEALED (port) = r;
+
+ if (r && !prev)
+ revealed_ports = scm_cons (port, revealed_ports);
+ else if (prev && !r)
+ revealed_ports = scm_delq_x (port, revealed_ports);
+
+ scm_i_pthread_mutex_unlock (&revealed_lock);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* Set the revealed count for a port. */
+SCM_DEFINE (scm_adjust_port_revealed_x, "adjust-port-revealed!", 2, 0, 0,
+ (SCM port, SCM addend),
+ "Add @var{addend} to the revealed count of @var{port}.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_adjust_port_revealed_x
+{
+ int a;
+
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPFPORT (1, port);
+
+ a = scm_to_int (addend);
+ if (!a)
+ return SCM_UNSPECIFIED;
+
+ scm_i_pthread_mutex_lock (&revealed_lock);
+
+ SCM_REVEALED (port) += a;
+ if (SCM_REVEALED (port) == a)
+ revealed_ports = scm_cons (port, revealed_ports);
+ else if (!SCM_REVEALED (port))
+ revealed_ports = scm_delq_x (port, revealed_ports);
+
+ scm_i_pthread_mutex_unlock (&revealed_lock);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
\f
static int
fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
#endif /* __MINGW32__ */
}
- /* If the GUILE_INSTALL_LOCALE environment variable is set to a
- nonzero value, we should install the locale via setlocale(). This
- behavior is off by default for compatibility with previous 2.0.x
- releases. It will be on by default in 2.2. */
- return get_integer_from_environment ("GUILE_INSTALL_LOCALE", 0);
+ static int
+ get_integer_from_environment (const char *var, int def)
+ {
+ char *end = 0;
+ char *val = getenv (var);
+ long res = def;
+ if (!val)
+ return def;
+ res = strtol (val, &end, 10);
+ if (end == val)
+ {
+ fprintf (stderr, "guile: warning: invalid %s: %s\n", var, val);
+ return def;
+ }
+ return res;
+ }
+
+ static int
+ should_install_locale (void)
+ {
++ /* If the GUILE_INSTALL_LOCALE environment variable is unset,
++ or set to a nonzero value, we should install the locale via
++ setlocale(). */
++ return get_integer_from_environment ("GUILE_INSTALL_LOCALE", 1);
+ }
+
int
main (int argc, char **argv)
{
#ifndef SCM_ISELECT_H
#define SCM_ISELECT_H
- /* Copyright (C) 1997,1998,2000,2001, 2002, 2006 Free Software Foundation, Inc.
-/* Copyright (C) 1997,1998,2000,2001, 2002, 2006, 2013 Free Software Foundation, Inc.
++/* Copyright (C) 1997,1998,2000,2001, 2002, 2006,
++ * 2013 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
return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
}
- case SCM_EXPANDED_SEQUENCE:
- return MAKMEMO_BEGIN (memoize_exps (REF (exp, SEQUENCE, EXPS), env));
+ case SCM_EXPANDED_PRIMCALL:
+ {
+ SCM proc, args;
+
+ if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
+ proc = MAKMEMO_TOP_REF (REF (exp, PRIMCALL, NAME));
+ else
+ proc = MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMCALL, NAME),
+ SCM_BOOL_F);
+ args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
+
+ return MAKMEMO_CALL (proc, scm_ilength (args), args);
+ }
+
+ case SCM_EXPANDED_SEQ:
+ return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
+ memoize (REF (exp, SEQ, TAIL), env));
case SCM_EXPANDED_LAMBDA:
- /* The body will be a lambda-case. */
+ /* The body will be a lambda-case or #f. */
{
- SCM meta, docstring, proc;
+ SCM meta, docstring, body, proc;
meta = REF (exp, LAMBDA, META);
docstring = scm_assoc_ref (meta, scm_sym_documentation);
{
if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x))))
return x;
- return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
- SCM_FRACTION_DENOMINATOR (x));
+ return scm_i_make_ratio_already_reduced
+ (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
+ SCM_FRACTION_DENOMINATOR (x));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs);
+ return scm_wta_dispatch_1 (g_scm_abs, x, 1, s_scm_abs);
}
#undef FUNC_NAME
return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x),
-SCM_COMPLEX_IMAG (x));
else if (SCM_FRACTIONP (x))
- return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
- SCM_FRACTION_DENOMINATOR (x));
+ return scm_i_make_ratio_already_reduced
+ (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
+ SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
+ return scm_wta_dispatch_1 (g_difference, x, SCM_ARG1, s_difference);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
}
}
else if (SCM_FRACTIONP (x))
- return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x),
- SCM_FRACTION_NUMERATOR (x));
+ return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x),
+ SCM_FRACTION_NUMERATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
+ return scm_wta_dispatch_1 (g_divide, x, SCM_ARG1, s_divide);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
else if (SCM_FRACTIONP (y))
/* a / b/c = ac / b */
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
- SCM_FRACTION_NUMERATOR (y));
+ SCM_FRACTION_NUMERATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_BIGP (x))
{
}
else if (SCM_FRACTIONP (y))
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
- SCM_FRACTION_NUMERATOR (y));
+ SCM_FRACTION_NUMERATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_REALP (x))
{
}
else if (SCM_FRACTIONP (y))
return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
- scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x)));
+ scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x)));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARG1, s_divide);
}
-
- SCM
- scm_divide (SCM x, SCM y)
- {
- return do_divide (x, y, 0);
- }
-
- static SCM scm_divide2real (SCM x, SCM y)
- {
- return do_divide (x, y, 1);
- }
#undef FUNC_NAME
{
if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
return z;
- return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED),
- SCM_FRACTION_DENOMINATOR (z));
+ return scm_i_make_ratio_already_reduced
+ (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED),
+ SCM_FRACTION_DENOMINATOR (z));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_magnitude, z, SCM_ARG1, s_scm_magnitude);
+ return scm_wta_dispatch_1 (g_scm_magnitude, z, SCM_ARG1,
+ s_scm_magnitude);
}
#undef FUNC_NAME
}
else if (SCM_NUMBERP (z))
{
- double xx = scm_to_double (z);
- if (xx < 0)
- return scm_c_make_rectangular (0.0, sqrt (-xx));
- else
- return scm_from_double (sqrt (xx));
+ if (SCM_I_INUMP (z))
+ {
+ scm_t_inum x = SCM_I_INUM (z);
+
+ if (SCM_LIKELY (x >= 0))
+ {
+ if (SCM_LIKELY (SCM_I_FIXNUM_BIT < DBL_MANT_DIG
+ || x < (1L << (DBL_MANT_DIG - 1))))
+ {
+ double root = sqrt (x);
+
+ /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
+ integer, then the result is exact. */
+ if (root == floor (root))
+ return SCM_I_MAKINUM ((scm_t_inum) root);
+ else
+ return scm_from_double (root);
+ }
+ else
+ {
+ mpz_t xx;
+ scm_t_inum root;
+
+ mpz_init_set_ui (xx, x);
+ if (mpz_perfect_square_p (xx))
+ {
+ mpz_sqrt (xx, xx);
+ root = mpz_get_ui (xx);
+ mpz_clear (xx);
+ return SCM_I_MAKINUM (root);
+ }
+ else
+ mpz_clear (xx);
+ }
+ }
+ }
+ else if (SCM_BIGP (z))
+ {
+ if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z)))
+ {
+ SCM root = scm_i_mkbig ();
+
+ mpz_sqrt (SCM_I_BIG_MPZ (root), SCM_I_BIG_MPZ (z));
+ scm_remember_upto_here_1 (z);
+ return scm_i_normbig (root);
+ }
+ else
+ {
+ long expon;
+ double signif = scm_i_big2dbl_2exp (z, &expon);
+
+ if (expon & 1)
+ {
+ signif *= 2;
+ expon--;
+ }
+ if (signif < 0)
+ return scm_c_make_rectangular
+ (0.0, ldexp (sqrt (-signif), expon / 2));
+ else
+ return scm_from_double (ldexp (sqrt (signif), expon / 2));
+ }
+ }
+ else if (SCM_FRACTIONP (z))
+ {
+ SCM n = SCM_FRACTION_NUMERATOR (z);
+ SCM d = SCM_FRACTION_DENOMINATOR (z);
+
+ if (exact_integer_is_perfect_square (n)
+ && exact_integer_is_perfect_square (d))
+ return scm_i_make_ratio_already_reduced
+ (exact_integer_floor_square_root (n),
+ exact_integer_floor_square_root (d));
+ else
+ {
+ double xx = scm_i_divide2double (n, d);
+ double abs_xx = fabs (xx);
+ long shift = 0;
+
+ if (SCM_UNLIKELY (abs_xx > DBL_MAX || abs_xx < DBL_MIN))
+ {
+ shift = (scm_to_long (scm_integer_length (n))
+ - scm_to_long (scm_integer_length (d))) / 2;
+ if (shift > 0)
+ d = left_shift_exact_integer (d, 2 * shift);
+ else
+ n = left_shift_exact_integer (n, -2 * shift);
+ xx = scm_i_divide2double (n, d);
+ }
+
+ if (xx < 0)
+ return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx), shift));
+ else
+ return scm_from_double (ldexp (sqrt (xx), shift));
+ }
+ }
+
+ /* Fallback method, when the cases above do not apply. */
+ {
+ double xx = scm_to_double (z);
+ if (xx < 0)
+ return scm_c_make_rectangular (0.0, sqrt (-xx));
+ else
+ return scm_from_double (sqrt (xx));
+ }
}
else
- SCM_WTA_DISPATCH_1 (g_scm_sqrt, z, 1, s_scm_sqrt);
+ return scm_wta_dispatch_1 (g_scm_sqrt, z, 1, s_scm_sqrt);
}
#undef FUNC_NAME
- /* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
-/* Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
++/* Copyright (C) 2001, 2009, 2010, 2011, 2012
++ * 2013 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
}
}
#undef FUNC_NAME
-
-/* The words in an objcode SCM object are as follows:
- - scm_tc7_objcode | type | flags
- - the struct scm_objcode C object
- - the parent of this objcode: either another objcode, a bytevector,
- or, in the case of mmap types, #f
- - "native code" -- not currently used.
- */
+#endif /* HAVE_SYS_MMAN_H */
static SCM
-make_objcode_from_file (int fd)
-#define FUNC_NAME "make_objcode_from_file"
+load_thunk_from_memory (char *data, size_t len)
+#define FUNC_NAME "load-thunk-from-memory"
{
- int ret;
- /* 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;
+ Elf_Ehdr header;
+ Elf_Phdr *ph;
+ const char *err_msg = 0;
+ char *base = 0;
+ size_t n, memsz = 0, alignment = 8;
+ int i;
+ int first_loadable = -1;
+ int start_segment = -1;
+ int prev_segment = -1;
+ int dynamic_segment = -1;
+ SCM init = SCM_BOOL_F, entry = SCM_BOOL_F;
+
+ if (len < sizeof header)
+ ABORT ("object file too small");
+
+ memcpy (&header, data, sizeof header);
+
+ if ((err_msg = check_elf_header (&header)))
+ goto cleanup;
+
+ n = header.e_phnum;
+ if (len < header.e_phoff + n * sizeof (Elf_Phdr))
+ goto cleanup;
+ ph = (Elf_Phdr*) (data + header.e_phoff);
+
+ for (i = 0; i < n; i++)
+ {
+ if (!ph[i].p_memsz)
+ continue;
- ret = fstat (fd, &st);
- if (ret < 0)
- SCM_SYSERROR;
+ if (ph[i].p_filesz != ph[i].p_memsz)
+ ABORT ("expected p_filesz == p_memsz");
- 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)));
+ if (!ph[i].p_flags)
+ ABORT ("expected nonzero segment flags");
-#ifdef HAVE_SYS_MMAN_H
- {
- char *addr;
- struct scm_objcode *data;
+ if (ph[i].p_align < alignment)
+ {
+ if (ph[i].p_align % alignment)
+ ABORT ("expected new alignment to be multiple of old");
+ alignment = ph[i].p_align;
+ }
- addr = mmap (0, st.st_size, PROT_READ, MAP_PRIVATE, fd, 0);
+ if (ph[i].p_type == PT_DYNAMIC)
+ {
+ if (dynamic_segment >= 0)
+ ABORT ("expected only one PT_DYNAMIC segment");
+ dynamic_segment = i;
+ }
- 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);
- }
+ if (first_loadable < 0)
+ {
+ if (ph[i].p_vaddr)
+ ABORT ("first loadable vaddr is not 0");
- verify_cookie (cookie, &st, fd, addr);
+ first_loadable = i;
+ }
+ if (ph[i].p_vaddr < memsz)
+ ABORT ("overlapping segments");
- if (data->len + data->metalen
- != (st.st_size - sizeof (*data) - sizeof cookie))
- {
- size_t total_len = sizeof (*data) + data->len + data->metalen;
+ if (ph[i].p_offset + ph[i].p_filesz > len)
+ ABORT ("segment beyond end of byte array");
+
+ memsz = ph[i].p_vaddr + ph[i].p_memsz;
+ }
- (void) close (fd);
- (void) munmap (addr, st.st_size);
+ if (first_loadable < 0)
+ ABORT ("no loadable segments");
- 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)));
- }
+ if (dynamic_segment < 0)
+ ABORT ("no PT_DYNAMIC segment");
- (void) close (fd);
- 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_BOOL_F_BITS, 0));
- }
-#else
- {
- SCM bv = scm_c_make_bytevector (st.st_size - sizeof cookie);
+ /* Now copy segments. */
- 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;
- if (errno)
- SCM_SYSERROR;
- scm_misc_error (FUNC_NAME, "file truncated while reading", SCM_EOL);
- }
+ /* We leak this memory, as we leak the memory mappings in
+ load_thunk_from_fd_using_mmap.
- (void) close (fd);
+ If the file is has an alignment of 8, use the standard malloc.
+ (FIXME to ensure alignment on non-GNU malloc.) Otherwise use
+ posix_memalign. We only use mprotect if the aligment is 4096. */
+ if (alignment == 8)
+ {
+ base = malloc (memsz);
+ if (!base)
+ goto cleanup;
+ }
+ else
+ if ((errno = posix_memalign ((void **) &base, alignment, memsz)))
+ goto cleanup;
+
+ memset (base, 0, memsz);
+
+ for (i = 0; i < n; i++)
+ {
+ if (!ph[i].p_memsz)
+ continue;
+
+ memcpy (base + ph[i].p_vaddr,
+ data + ph[i].p_offset,
+ ph[i].p_memsz);
+
+ if (start_segment < 0)
+ {
+ start_segment = prev_segment = i;
+ continue;
+ }
+
+ if (ph[i].p_flags == ph[start_segment].p_flags)
+ {
+ prev_segment = i;
+ continue;
+ }
+
+ if (alignment == 4096)
+ if (mprotect_segments (base, &ph[start_segment], &ph[prev_segment]))
+ goto cleanup;
+
+ /* Open a new set of segments. */
+ start_segment = prev_segment = i;
+ }
+
+ /* Mprotect the last segments. */
+ if (alignment == 4096)
+ if (mprotect_segments (base, &ph[start_segment], &ph[prev_segment]))
+ goto cleanup;
+
+ if ((err_msg = process_dynamic_segment (base, &ph[dynamic_segment],
+ &init, &entry)))
+ goto cleanup;
+
+ if (scm_is_true (init))
+ scm_call_0 (init);
- verify_cookie (cookie, &st, -1, NULL);
+ /* Finally! Return the thunk. */
+ return entry;
- return scm_bytecode_to_native_objcode (bv);
+ cleanup:
+ {
+ if (errno)
+ SCM_SYSERROR;
+ scm_misc_error (FUNC_NAME, err_msg ? err_msg : "error loading ELF file",
+ SCM_EOL);
}
- fd = open (c_filename, O_RDONLY | O_CLOEXEC);
+}
+#undef FUNC_NAME
+
+#ifndef HAVE_SYS_MMAN_H
+static SCM
+load_thunk_from_fd_using_read (int fd)
+#define FUNC_NAME "load-thunk-from-disk"
+{
+ char *data;
+ size_t len;
+ struct stat st;
+ int ret;
+
+ ret = fstat (fd, &st);
+ if (ret < 0)
+ SCM_SYSERROR;
+ len = st.st_size;
+ data = scm_gc_malloc_pointerless (len, "objcode");
+ if (full_read (fd, data, len) != len)
+ {
+ int errno_save = errno;
+ (void) close (fd);
+ errno = errno_save;
+ if (errno)
+ SCM_SYSERROR;
+ scm_misc_error (FUNC_NAME, "short read while loading objcode",
+ SCM_EOL);
+ }
+ (void) close (fd);
+ return load_thunk_from_memory (data, len);
+}
+#undef FUNC_NAME
+#endif /* ! HAVE_SYS_MMAN_H */
+
+SCM_DEFINE (scm_load_thunk_from_file, "load-thunk-from-file", 1, 0, 0,
+ (SCM filename),
+ "")
+#define FUNC_NAME s_scm_load_thunk_from_file
+{
+ char *c_filename;
+ int fd;
+
+ SCM_VALIDATE_STRING (1, filename);
+
+ c_filename = scm_to_locale_string (filename);
++ fd = open (c_filename, O_RDONLY | O_BINARY | O_CLOEXEC);
+ free (c_filename);
+ if (fd < 0) SCM_SYSERROR;
+
+#ifdef HAVE_SYS_MMAN_H
+ return load_thunk_from_fd_using_mmap (fd);
+#else
+ return load_thunk_from_fd_using_read (fd);
#endif
}
#undef FUNC_NAME
}
/* We can't use `scm_c_read ()' since it blocks. */
- c_chr = scm_getc_unlocked (port);
- c_chr = scm_get_byte_or_eof (port);
++ c_chr = scm_get_byte_or_eof_unlocked (port);
if (c_chr != EOF)
{
c_bv[c_total] = (char) c_chr;
c_total++;
}
}
- while ((scm_is_true (scm_char_ready_p (port)))
- && (!SCM_EOF_OBJECT_P (scm_peek_char (port))));
+ /* XXX: We want to check for the availability of a byte, but that's
+ what `scm_char_ready_p' actually does. */
+ while (scm_is_true (scm_char_ready_p (port))
- && (scm_peek_byte_or_eof (port) != EOF));
++ && (scm_peek_byte_or_eof_unlocked (port) != EOF));
if (c_total == 0)
{
/* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
reached. */
- c_read = scm_c_read (port, c_bv + c_total, c_count);
+ c_read = scm_c_read_unlocked (port, c_bv + c_total, c_count);
c_total += c_read, c_count -= c_read;
}
- while (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
+ while (scm_peek_byte_or_eof (port) != EOF);
if (c_total == 0)
{
{
SCM obj;
- SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
- SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit;
+ scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
+ scm_i_pthread_setspecific (current_mark_stack_limit, mark_stack_limit);
/* Invoke the SMOB's mark procedure, which will in turn invoke
- `scm_gc_mark ()', which may modify `current_mark_stack_ptr'. */
+ `scm_gc_mark', which may modify `current_mark_stack_pointer'. */
obj = scm_smobs[smobnum].mark (cell);
- mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr;
+ mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
- if (SCM_NIMP (obj))
+ if (SCM_HEAP_OBJECT_P (obj))
/* Mark the returned object. */
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
mark_stack_ptr,
void
scm_gc_mark (SCM o)
{
- #define CURRENT_MARK_PTR \
- ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr))
- #define CURRENT_MARK_LIMIT \
- ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit))
-
- if (SCM_NIMP (o))
+ if (SCM_HEAP_OBJECT_P (o))
{
- /* At this point, the `current_mark_*' fields of the current thread
- must be defined (they are set in `smob_mark ()'). */
- register struct GC_ms_entry *mark_stack_ptr;
+ void *mark_stack_ptr, *mark_stack_limit;
- if (!CURRENT_MARK_PTR)
+ mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
+ mark_stack_limit = scm_i_pthread_getspecific (current_mark_stack_limit);
+
+ if (mark_stack_ptr == NULL)
/* The function was not called from a mark procedure. */
abort ();
--/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
++/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007,
++ * 2008, 2009, 2010, 2011, 2012, 2013 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
#ifndef SCM_THREADS_H
#define SCM_THREADS_H
- /* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
+ /* Copyright (C) 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006,
- * 2007, 2008, 2009, 2011, 2013 Free Software Foundation, Inc.
++ * 2007, 2008, 2009, 2011, 2012, 2013 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
;;;
(define %cond-expand-features
- ;; Adjust the above comment when changing this.
+ ;; This should contain only features that are present in core Guile,
+ ;; before loading any modules. Modular features are handled by
+ ;; placing 'cond-expand-provide' in the relevant module.
'(guile
guile-2
+ guile-2.2
r5rs
srfi-0 ;; cond-expand itself
- srfi-4 ;; homogenous numeric vectors
- srfi-6 ;; open-input-string etc, in the guile core
+ srfi-4 ;; homogeneous numeric vectors
+ ;; We omit srfi-6 because the 'open-input-string' etc in Guile
+ ;; core are not conformant with SRFI-6; they expose details
+ ;; of the binary I/O model and may fail to support some characters.
srfi-13 ;; string library
srfi-14 ;; character sets
srfi-23 ;; `error` procedure
(primitive 'if)
(recurse test) (recurse consequent) (recurse alternate))
- ((<sequence> exps) (primitive 'begin) (for-each recurse exps))
+ ((<seq> head tail)
+ (primitive 'begin) (recurse head) (recurse tail))
+
- ((<lambda> body) (recurse body))
+ ((<lambda> body)
+ (if body (recurse body)))
((<lambda-case> req opt rest kw inits gensyms body alternate)
(primitive 'lambda)
(up tree (loop alternate
(loop consequent
(loop test (down tree result))))))
- ((<application> proc args)
+ ((<call> proc args)
(up tree (loop (cons proc args) (down tree result))))
- ((<sequence> exps)
- (up tree (loop exps (down tree result))))
+ ((<primcall> name args)
+ (up tree (loop args (down tree result))))
+ ((<seq> head tail)
+ (up tree (loop tail (loop head (down tree result)))))
((<lambda> body)
- (up tree (loop body (down tree result))))
+ (let ((result (down tree result)))
+ (up tree
+ (if body
+ (loop body result)
+ result))))
((<lambda-case> inits body alternate)
(up tree (if alternate
(loop alternate
(let*-values (((seed ...) (foldts test seed ...))
((seed ...) (foldts consequent seed ...)))
(foldts alternate seed ...)))
- ((<application> proc args)
+ ((<call> proc args)
(let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...)))
- ((<sequence> exps)
- (fold-values foldts exps seed ...))
+ ((<primcall> name args)
+ (fold-values foldts args seed ...))
+ ((<seq> head tail)
+ (let-values (((seed ...) (foldts head seed ...)))
+ (foldts tail seed ...)))
((<lambda> body)
- (foldts body seed ...))
+ (if body
+ (foldts body seed ...)
+ (values seed ...)))
((<lambda-case> inits body alternate)
(let-values (((seed ...) (fold-values foldts inits seed ...)))
(if alternate
body)
(($ <dynlet> src () () body)
body)
- (make-application
+ (($ <lambda> src meta #f)
+ ;; Give a body to case-lambda with no clauses.
+ (make-lambda
+ src meta
+ (make-lambda-case
+ #f '() #f #f #f '() '()
- (make-primitive-ref #f 'throw)
++ (make-primcall
+ #f
++ 'throw
+ (list (make-const #f 'wrong-number-of-args)
+ (make-const #f #f)
+ (make-const #f "Wrong number of arguments")
+ (make-const #f '())
+ (make-const #f #f)))
+ #f)))
(($ <prompt> src tag body handler)
(define (escape-only? handler)
(match handler
(c
(return c (intersection (concat db++ db+) (concat db-- db-)))))))
- (($ <application> src proc args)
+ (($ <primcall> src primitive args)
+ (let*-values (((args db*) (parallel-visit args db env 'value)))
+ (return (make-primcall src primitive args) db*)))
+ (($ <call> src proc args)
(let*-values (((proc db*) (visit proc db env 'value))
((args db**) (parallel-visit args db env 'value)))
- (return (make-application src proc args)
+ (return (make-call src proc args)
(concat db** db*))))
(($ <lambda> src meta body)
- (let*-values (((body _) (visit body (control-flow-boundary db)
- env 'values)))
+ (let*-values (((body _) (if body
+ (visit body (control-flow-boundary db)
+ env 'values)
+ (values #f #f))))
(return (make-lambda src meta body)
vlist-null)))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
(cause &type-check))))
(($ <lambda-case>)
(logior (compute-effects body)
- (cause &type-check))))))
+ (cause &type-check)))
+ (#f
+ ;; Calling a case-lambda with no clauses
+ ;; definitely causes bailout.
+ (logior (cause &definite-bailout)
+ (cause &possible-bailout))))))
;; Bailout primitives.
- (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
- args)
+ (($ <primcall> _ (? bailout-primitive? name) args)
(logior (accumulate-effects args)
(cause &definite-bailout)
(cause &possible-bailout)))
(define (lift-applied-lambda body gensyms)
(and (not opt) rest (not kw)
(match body
- (($ <application> _
- ($ <primitive-ref> _ '@apply)
+ (($ <primcall> _ '@apply
- (($ <lambda> _ _ lcase)
+ (($ <lambda> _ _ (and lcase ($ <lambda-case>)))
($ <lexical-ref> _ _ sym)
...))
(and (equal? sym gensyms)
srcdir="$(srcdir)" \
builddir="$(builddir)" \
@LOCALCHARSET_TESTS_ENVIRONMENT@ \
- GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env"
+ GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env"
- ## Check for headers in $(srcdir) and bulid dir before $(CPPFLAGS), which
+ ## Check for headers in $(srcdir) and build dir before $(CPPFLAGS), which
## may point us to an old, installed version of guile.
AM_CPPFLAGS = -I$(top_srcdir) -I$(top_builddir) \
-I$(top_srcdir)/lib -I$(top_builddir)/lib
(even? 10))
(current-module))))
+ (define-module (test-suite test-syncase-3)
+ #:autoload (test-syncase-3-does-not-exist) (baz))
+
+ (define-module (test-suite test-syncase)) ;; back to main module
+
+ (pass-if "missing autoloads do not foil psyntax"
+ (parameterize ((current-warning-port (%make-void-port "w")))
+ (eval '(if #f (baz) #t)
+ (resolve-module '(test-suite test-syncase-3)))))
++
+(use-modules (system syntax))
+
+(with-test-prefix "syntax-local-binding"
+ (define-syntax syntax-type
+ (lambda (x)
+ (syntax-case x ()
+ ((_ id resolve?)
+ (call-with-values
+ (lambda ()
+ (syntax-local-binding
+ #'id
+ #:resolve-syntax-parameters? (syntax->datum #'resolve?)))
+ (lambda (type value)
+ (with-syntax ((type (datum->syntax #'id type)))
+ #''type)))))))
+
+ (define-syntax-parameter foo
+ (syntax-rules ()))
+
+ (pass-if "syntax-parameters (resolved)"
+ (equal? (syntax-type foo #t) 'macro))
+
+ (pass-if "syntax-parameters (unresolved)"
+ (equal? (syntax-type foo #f) 'syntax-parameter)))
HCoop / bpt / guile.git / commitdiff