diff options
Diffstat (limited to 'libguile')
40 files changed, 428 insertions, 207 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 2077c4dac..f5e859023 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -92,11 +92,12 @@ guile_filter_doc_snarfage_SOURCES = c-tokenize.c ## Override default rule; this should be compiled for BUILD host. ## For some reason, OBJEXT does not include the dot c-tokenize.$(OBJEXT): c-tokenize.c - $(AM_V_GEN) \ - if [ "$(cross_compiling)" = "yes" ]; then \ - $(CC_FOR_BUILD) -I$(top_builddir) -c -o $@ $<; \ - else \ - $(COMPILE) -c -o $@ $<; \ + $(AM_V_GEN) \ + if [ "$(cross_compiling)" = "yes" ]; then \ + $(CC_FOR_BUILD) -DCROSS_COMPILING=1 -I$(top_builddir) \ + -c -o "$@" "$<"; \ + else \ + $(COMPILE) -c -o "$@" "$<"; \ fi ## Override default rule; this should run on BUILD host. @@ -460,6 +461,37 @@ EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = _scm.h \ install-exec-hook: rm -f $(DESTDIR)$(bindir)/guile-snarf.awk +install-data-hook: libguile-2.2-gdb.scm + @$(MKDIR_P) $(DESTDIR)$(libdir) +## We want to install libguile-2.2-gdb.scm as SOMETHING-gdb.scm. +## SOMETHING is the full name of the final library. We want to ignore +## symlinks, the .la file, and any previous -gdb.py file. This is +## inherently fragile, but there does not seem to be a better option, +## because libtool hides the real names from us. (Trick courtesy of +## GNU libstdc++.) + @here=`pwd`; cd $(DESTDIR)$(libdir); \ + for file in libguile-@GUILE_EFFECTIVE_VERSION@*; do \ + case $$file in \ + *-gdb.scm) ;; \ + *.la) ;; \ + *) if test -h $$file; then \ + continue; \ + fi; \ + libname=$$file;; \ + esac; \ + done; \ + cd $$here; \ + echo " $(INSTALL_DATA) $< \ +$(DESTDIR)$(libdir)/$$libname-gdb.scm"; \ + $(INSTALL_DATA) "$<" \ + "$(DESTDIR)$(libdir)/$$libname-gdb.scm" + +# Remove the GDB support file and the Info 'dir' file that +# 'install-info' 5.x installs. +uninstall-hook: + -rm "$(DESTDIR)$(libdir)/libguile-@GUILE_EFFECTIVE_VERSION@"*-gdb.scm + -rm -f "$(DESTDIR)$(infodir)/dir" + ## This is kind of nasty... there are ".c" files that we don't want to ## compile, since they are #included. So instead we list them here. ## Perhaps we can deal with them normally once the merge seems to be @@ -650,12 +682,13 @@ bin_SCRIPTS = guile-snarf # and people feel like maintaining them. For now, this is not the case. noinst_SCRIPTS = guile-snarf-docs -EXTRA_DIST = ChangeLog-scm ChangeLog-threads \ - ChangeLog-1996-1999 ChangeLog-2000 ChangeLog-2008 \ - guile-func-name-check \ - cpp-E.syms cpp-E.c cpp-SIG.syms cpp-SIG.c \ - c-tokenize.lex \ - scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map +EXTRA_DIST = ChangeLog-scm ChangeLog-threads \ + ChangeLog-1996-1999 ChangeLog-2000 ChangeLog-2008 \ + guile-func-name-check \ + cpp-E.syms cpp-E.c cpp-SIG.syms cpp-SIG.c \ + c-tokenize.lex \ + scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map \ + libguile-2.2-gdb.scm # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi diff --git a/libguile/async.c b/libguile/async.c index 80f561d10..1e5bc302d 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, + * 2009, 2010, 2011, 2014 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 @@ -36,9 +37,7 @@ #ifdef HAVE_STRING_H #include <string.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #include <full-write.h> diff --git a/libguile/backtrace.c b/libguile/backtrace.c index fa12a5dd0..0c0f11007 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -1,5 +1,6 @@ /* Printing of backtraces and error messages - * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010, 2011, 2014 Free Software Foundation + * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2009, + * 2010, 2011, 2014 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 @@ -26,9 +27,7 @@ #include "libguile/_scm.h" -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef HAVE_IO_H #include <io.h> #endif diff --git a/libguile/bdw-gc.h b/libguile/bdw-gc.h index 2deb97e94..6e2f4561b 100644 --- a/libguile/bdw-gc.h +++ b/libguile/bdw-gc.h @@ -23,7 +23,7 @@ #include "libguile/scmconfig.h" -#ifdef SCM_USE_PTHREAD_THREADS +#if SCM_USE_PTHREAD_THREADS /* When pthreads are used, let `libgc' know about it and redirect allocation calls such as `GC_MALLOC ()' to (contention-free, faster) thread-local diff --git a/libguile/c-tokenize.lex b/libguile/c-tokenize.lex index 856224e46..03fe9898c 100644 --- a/libguile/c-tokenize.lex +++ b/libguile/c-tokenize.lex @@ -1,3 +1,14 @@ +%top{ +/* Include <config.h> before anything else because Gnulib headers such + as <stdio.h> rely on it. + + However, when cross-compiling, don't include <config.h> because it + contains information about the host, not about the build. */ +#ifndef CROSS_COMPILING +# include <config.h> +#endif +} + %option noyywrap %option nounput %pointer @@ -14,8 +25,6 @@ FLOQUAL (f|F|l|L) INTQUAL (l|L|ll|LL|lL|Ll|u|U) %{ -#include <config.h> - #include <stdio.h> #include <stdlib.h> #include <string.h> diff --git a/libguile/chars.c b/libguile/chars.c index 9f50c1e25..064fca40a 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -536,7 +536,7 @@ static const char *const scm_r5rs_charnames[] = { "space", "newline" }; -static const scm_t_uint32 const scm_r5rs_charnums[] = { +static const scm_t_uint32 scm_r5rs_charnums[] = { 0x20, 0x0a }; @@ -548,7 +548,7 @@ static const char *const scm_r6rs_charnames[] = { /* 'space' and 'newline' are already included from the R5RS list. */ }; -static const scm_t_uint32 const scm_r6rs_charnums[] = { +static const scm_t_uint32 scm_r6rs_charnums[] = { 0x00, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x1b, 0x7f }; @@ -559,7 +559,7 @@ static const char *const scm_r7rs_charnames[] = { "escape" }; -static const scm_t_uint32 const scm_r7rs_charnums[] = { +static const scm_t_uint32 scm_r7rs_charnums[] = { 0x1b }; @@ -575,7 +575,7 @@ static const char *const scm_C0_control_charnames[] = { "sp", "del" }; -static const scm_t_uint32 const scm_C0_control_charnums[] = { +static const scm_t_uint32 scm_C0_control_charnums[] = { 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, @@ -589,7 +589,7 @@ static const char *const scm_alt_charnames[] = { "null", "nl", "np" }; -static const scm_t_uint32 const scm_alt_charnums[] = { +static const scm_t_uint32 scm_alt_charnums[] = { 0x00, 0x0a, 0x0c }; diff --git a/libguile/error.c b/libguile/error.c index b61e90b37..2878fa0dd 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -40,9 +40,7 @@ #ifdef HAVE_STRING_H #include <string.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif /* For Windows... */ #ifdef HAVE_IO_H diff --git a/libguile/filesys.c b/libguile/filesys.c index aa3e67165..a2280a51a 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1,5 +1,5 @@ /* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004, 2006, - * 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. + * 2009, 2010, 2011, 2012, 2013, 2014 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 @@ -71,9 +71,7 @@ # endif #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef LIBC_H_WITH_UNISTD_H #include <libc.h> @@ -109,12 +107,6 @@ #include <full-write.h> -/* Some more definitions for the native Windows port. */ -#ifdef __MINGW32__ -# define fsync(fd) _commit (fd) -#endif /* __MINGW32__ */ - - /* Two helper macros for an often used pattern */ @@ -564,7 +556,6 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0, } #undef FUNC_NAME -#ifdef HAVE_LSTAT SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, (SCM str), "Similar to @code{stat}, but does not follow symbolic links, i.e.,\n" @@ -587,7 +578,6 @@ SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, return scm_stat2scm (&stat_temp); } #undef FUNC_NAME -#endif /* HAVE_LSTAT */ #ifdef HAVE_POSIX @@ -595,7 +585,6 @@ SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, /* {Modifying Directories} */ -#ifdef HAVE_LINK SCM_DEFINE (scm_link, "link", 2, 0, 0, (SCM oldpath, SCM newpath), "Creates a new name @var{newpath} in the file system for the\n" @@ -614,7 +603,6 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME -#endif /* HAVE_LINK */ /* {Navigating Directories} @@ -1017,7 +1005,6 @@ SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0, #undef FUNC_NAME #endif /* HAVE_SYMLINK */ -#ifdef HAVE_READLINK SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0, (SCM path), "Return the value of the symbolic link named by @var{path} (a\n" @@ -1056,7 +1043,6 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0, return result; } #undef FUNC_NAME -#endif /* HAVE_READLINK */ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0, (SCM oldfile, SCM newfile), @@ -1259,7 +1245,6 @@ SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0, #undef FUNC_NAME #endif /* HAVE_GETCWD */ -#ifdef HAVE_MKDIR SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0, (SCM path, SCM mode), "Create a new directory named by @var{path}. If @var{mode} is omitted\n" @@ -1286,9 +1271,7 @@ SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME -#endif /* HAVE_MKDIR */ -#ifdef HAVE_RMDIR SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0, (SCM path), "Remove the existing directory named by @var{path}. The directory must\n" @@ -1303,27 +1286,6 @@ SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME -#endif - -#ifdef HAVE_RENAME -#define my_rename rename -#else -static int -my_rename (const char *oldname, const char *newname) -{ - int rv; - - SCM_SYSCALL (rv = link (oldname, newname)); - if (rv == 0) - { - SCM_SYSCALL (rv = unlink (oldname)); - if (rv != 0) - /* unlink failed. remove new name */ - SCM_SYSCALL (unlink (newname)); - } - return rv; -} -#endif SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0, (SCM oldname, SCM newname), @@ -1335,7 +1297,7 @@ SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0, STRING2_SYSCALL (oldname, c_oldname, newname, c_newname, - rv = my_rename (c_oldname, c_newname)); + rv = rename (c_oldname, c_newname)); if (rv != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -1470,10 +1432,6 @@ SCM_DEFINE (scm_umask, "umask", 0, 1, 0, } #undef FUNC_NAME -#ifndef HAVE_MKSTEMP -extern int mkstemp (char *); -#endif - SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0, (SCM tmpl), "Create a new unique file in the file system and return a new\n" diff --git a/libguile/finalizers.c b/libguile/finalizers.c index b37dbde6b..82f292cd2 100644 --- a/libguile/finalizers.c +++ b/libguile/finalizers.c @@ -23,9 +23,7 @@ # include <config.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #include <fcntl.h> #include <full-write.h> diff --git a/libguile/fports.c b/libguile/fports.c index 672f575a8..e4038def6 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -33,9 +33,7 @@ #ifdef HAVE_STRING_H #include <string.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef HAVE_IO_H #include <io.h> #endif diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c index d229b90d9..894ca0668 100644 --- a/libguile/gc-malloc.c +++ b/libguile/gc-malloc.c @@ -1,5 +1,6 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. + * 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, + * 2014 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 @@ -56,9 +57,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/debug-malloc.h" #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif /* INIT_MALLOC_LIMIT is the initial amount of malloc usage which will diff --git a/libguile/gc.c b/libguile/gc.c index bc35faf33..fe93cbaf9 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -66,9 +66,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/debug-malloc.h" #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif /* Size in bytes of the initial heap. This should be about the size of result of 'guile -c "(display (assq-ref (gc-stats) diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in index c73e8ce1e..47bbc0422 100644 --- a/libguile/guile-snarf.in +++ b/libguile/guile-snarf.in @@ -1,7 +1,8 @@ #!/bin/sh # Extract the initialization actions from source files. # -# Copyright (C) 1996, 97, 98, 99, 2000, 2001, 2002, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. +# Copyright (C) 1996, 97, 98, 99, 2000, 2001, 2002, 2004, 2006, 2008, +# 2009, 2014 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as @@ -51,19 +52,21 @@ modern_snarf () # writes stdout ## empty file. echo "/* cpp arguments: $@ */" ; ${cpp} -DSCM_MAGIC_SNARF_INITS -DSCM_MAGIC_SNARFER "$@" > ${temp} && cpp_ok_p=true - sed -ne 's/ *\^ *: *\^/\ + sed -ne 's/ *\^ *\^ */\ / -h -s/\n.*// +s/.*\n// t x d : x -s/.*\^ *\^ *\(.*\)/\1;/ +s/ *\^ *: *\^ */;\ +/ t y -d +N +s/\n\(#.*\)/ / +s/\n/ / +t x : y -p -x +P D' ${temp} } diff --git a/libguile/init.c b/libguile/init.c index 81cf99707..6de7a2192 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -1,5 +1,6 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2006, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. + * 2004, 2006, 2009, 2010, 2011, 2012, 2013, + * 2014 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 @@ -144,9 +145,7 @@ #ifdef HAVE_STRING_H #include <string.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif diff --git a/libguile/ioext.c b/libguile/ioext.c index 94b0f4f0f..659eabcf5 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2006, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2006, + * 2011, 2014 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 @@ -41,9 +42,7 @@ #ifdef HAVE_IO_H #include <io.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0, diff --git a/libguile/iselect.h b/libguile/iselect.h index 1c7b12db0..945ad14af 100644 --- a/libguile/iselect.h +++ b/libguile/iselect.h @@ -29,8 +29,6 @@ /* Needed for FD_SET on some systems. */ #include <sys/types.h> -#if SCM_HAVE_SYS_SELECT_H - #include <sys/select.h> SCM_API int scm_std_select (int fds, @@ -41,8 +39,6 @@ SCM_API int scm_std_select (int fds, #define SELECT_TYPE fd_set -#endif /* SCM_HAVE_SYS_SELECT_H */ - #endif /* SCM_ISELECT_H */ /* diff --git a/libguile/libguile-2.2-gdb.scm b/libguile/libguile-2.2-gdb.scm new file mode 100644 index 000000000..93ba1a3ea --- /dev/null +++ b/libguile/libguile-2.2-gdb.scm @@ -0,0 +1,164 @@ +;;; GDB debugging support for Guile. +;;; +;;; Copyright 2014 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 +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guile-gdb) + #:use-module (system base types) + #:use-module ((gdb) #:hide (symbol?)) + #:use-module (gdb printing) + #:use-module (srfi srfi-11) + #:export (%gdb-memory-backend + display-vm-frames)) + +;;; Commentary: +;;; +;;; This file defines GDB extensions to pretty-print 'SCM' objects, and +;;; to walk Guile's virtual machine stack. +;;; +;;; This file is installed under a name that follows the convention that +;;; allows GDB to auto-load it anytime the user is debugging libguile +;;; (info "(gdb) objfile-gdbdotext file"). +;;; +;;; Code: + +(define (type-name-from-descriptor descriptor-array type-number) + "Return the name of the type TYPE-NUMBER as seen in DESCRIPTOR-ARRAY, or #f +if the information is not available." + (let ((descriptors (lookup-global-symbol descriptor-array))) + (and descriptors + (let ((code (type-code (symbol-type descriptors)))) + (or (= TYPE_CODE_ARRAY code) + (= TYPE_CODE_PTR code))) + (let* ((type-descr (value-subscript (symbol-value descriptors) + type-number)) + (name (value-field type-descr "name"))) + (value->string name))))) + +(define %gdb-memory-backend + ;; The GDB back-end to access the inferior's memory. + (let ((void* (type-pointer (lookup-type "void")))) + (define (dereference-word address) + ;; Return the word at ADDRESS. + (value->integer + (value-dereference (value-cast (make-value address) + (type-pointer void*))))) + + (define (open address size) + ;; Return a port to the SIZE bytes starting at ADDRESS. + (if size + (open-memory #:start address #:size size) + (open-memory #:start address))) + + (define (type-name kind number) + ;; Return the type name of KIND type NUMBER. + (type-name-from-descriptor (case kind + ((smob) "scm_smobs") + ((port) "scm_ptobs")) + number)) + + (memory-backend dereference-word open type-name))) + + +;;; +;;; GDB pretty-printer registration. +;;; + +(define scm-value->string + (lambda* (value #:optional (backend %gdb-memory-backend)) + "Return a representation of value VALUE as a string." + (object->string (scm->object (value->integer value) backend)))) + +(define %scm-pretty-printer + (make-pretty-printer "SCM" + (lambda (pp value) + (let ((name (type-name (value-type value)))) + (and (and name (string=? name "SCM")) + (make-pretty-printer-worker + #f ; display hint + (lambda (printer) + (scm-value->string value %gdb-memory-backend)) + #f)))))) + +(define* (register-pretty-printer #:optional objfile) + (prepend-pretty-printer! objfile %scm-pretty-printer)) + +(register-pretty-printer) + + +;;; +;;; VM stack walking. +;;; + +(define (find-vm-engine-frame) + "Return the bottom-most frame containing a call to the VM engine." + (define (vm-engine-frame? frame) + (let ((sym (frame-function frame))) + (and sym + (member (symbol-name sym) + '("vm_debug_engine" "vm_regular_engine"))))) + + (let loop ((frame (newest-frame))) + (and frame + (if (vm-engine-frame? frame) + frame + (loop (frame-older frame)))))) + +(define (vm-stack-pointer) + "Return the current value of the VM stack pointer or #f." + (let ((frame (find-vm-engine-frame))) + (and frame + (frame-read-var frame "sp")))) + +(define (vm-frame-pointer) + "Return the current value of the VM frame pointer or #f." + (let ((frame (find-vm-engine-frame))) + (and frame + (frame-read-var frame "fp")))) + +(define* (display-vm-frames #:optional (port (current-output-port))) + "Display the VM frames on PORT." + (define (display-objects start end) + ;; Display all the objects (arguments and local variables) located + ;; between START and END. + (let loop ((number 0) + (address start)) + (when (and (> start 0) (<= address end)) + (let ((object (dereference-word %gdb-memory-backend address))) + ;; TODO: Push onto GDB's value history. + (format port " slot ~a -> ~s~%" + number (scm->object object %gdb-memory-backend))) + (loop (+ 1 number) (+ address %word-size))))) + + (let loop ((number 0) + (sp (value->integer (vm-stack-pointer))) + (fp (value->integer (vm-frame-pointer)))) + (unless (zero? fp) + (let-values (((ra mvra link proc) + (vm-frame fp %gdb-memory-backend))) + (format port "#~a ~s~%" number (scm->object proc %gdb-memory-backend)) + (display-objects fp sp) + (loop (+ 1 number) (- fp (* 5 %word-size)) link))))) + +;; See libguile/frames.h. +(define* (vm-frame fp #:optional (backend %gdb-memory-backend)) + "Return the components of the stack frame at FP." + (let ((caller (dereference-word backend (- fp %word-size))) + (ra (dereference-word backend (- fp (* 2 %word-size)))) + (mvra (dereference-word backend (- fp (* 3 %word-size)))) + (link (dereference-word backend (- fp (* 4 %word-size))))) + (values ra mvra link caller))) + +;;; libguile-2.2-gdb.scm ends here diff --git a/libguile/list.c b/libguile/list.c index 1f44ad032..41cc937f7 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -374,18 +374,49 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, "@code{reverse!}") #define FUNC_NAME s_scm_reverse_x { - SCM_VALIDATE_LIST (1, lst); + SCM old_lst = lst; + SCM tail = SCM_BOOL_F; + if (SCM_UNBNDP (new_tail)) new_tail = SCM_EOL; - while (!SCM_NULL_OR_NIL_P (lst)) + if (SCM_NULL_OR_NIL_P (lst)) + return new_tail; + + /* SCM_VALIDATE_LIST would run through the whole list to make sure it + is not eventually circular. In contrast to most list operations, + reverse! cannot get stuck in an infinite loop but arrives back at + the start when given an eventually or fully circular list. Because + of that, we can save the cost of an upfront proper list check at + the price of having to do a double reversal in the error case. + */ + + while (scm_is_pair (lst)) { SCM old_tail = SCM_CDR (lst); - SCM_SETCDR (lst, new_tail); - new_tail = lst; + SCM_SETCDR (lst, tail); + tail = lst; lst = old_tail; } - return new_tail; + + if (SCM_LIKELY (SCM_NULL_OR_NIL_P (lst))) + { + SCM_SETCDR (old_lst, new_tail); + return tail; + } + + /* We did not start with a proper list. Undo the reversal. */ + + while (scm_is_pair (tail)) + { + SCM old_tail = SCM_CDR (tail); + SCM_SETCDR (tail, lst); + lst = tail; + tail = old_tail; + } + + SCM_WRONG_TYPE_ARG (1, lst); + return lst; } #undef FUNC_NAME diff --git a/libguile/load.c b/libguile/load.c index 5019201dc..d24b4ae02 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2004, 2006, 2008, - * 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. + * 2009, 2010, 2011, 2012, 2013, 2014 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 @@ -49,10 +49,7 @@ #include <sys/types.h> #include <sys/stat.h> - -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif /* HAVE_UNISTD_H */ #ifdef HAVE_PWD_H #include <pwd.h> diff --git a/libguile/mallocs.c b/libguile/mallocs.c index b4499bc6d..9f3584a09 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -1,5 +1,6 @@ /* classes: src_files - * Copyright (C) 1995,1997,1998,2000,2001, 2006, 2011 Free Software Foundation, Inc. + * Copyright (C) 1995,1997,1998,2000,2001, 2006, 2011, + * 2014 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,9 +33,7 @@ #include "libguile/mallocs.h" -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif diff --git a/libguile/mkstemp.c b/libguile/mkstemp.c index a7eaf105b..d752d0714 100644 --- a/libguile/mkstemp.c +++ b/libguile/mkstemp.c @@ -1,4 +1,6 @@ -/* Copyright (C) 1991, 1992, 1996, 1998, 2001, 2006, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1991, 1992, 1996, 1998, 2001, 2006, 2013, + 2014 Free Software Foundation, Inc. + This file is derived from mkstemps.c from the GNU Libiberty Library which in turn is derived from the GNU C Library. @@ -33,9 +35,7 @@ #include <errno.h> #include <stdio.h> #include <fcntl.h> -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef HAVE_SYS_TIME_H #include <sys/time.h> #endif diff --git a/libguile/numbers.c b/libguile/numbers.c index f4e8b2710..14d98ffea 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1,6 +1,6 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, - * 2013 Free Software Foundation, Inc. + * 2013, 2014 Free Software Foundation, Inc. * * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * and Bellcore. See scm_divide. @@ -4679,9 +4679,15 @@ SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0, if (SCM_I_INUMP (j)) { - /* bits above what's in an inum follow the sign bit */ - iindex = min (iindex, SCM_LONG_BIT - 1); - return scm_from_bool ((1L << iindex) & SCM_I_INUM (j)); + if (iindex < SCM_LONG_BIT - 1) + /* Arrange for the number to be converted to unsigned before + checking the bit, to ensure that we're testing the bit in a + two's complement representation (regardless of the native + representation. */ + return scm_from_bool ((1UL << iindex) & SCM_I_INUM (j)); + else + /* Portably check the sign. */ + return scm_from_bool (SCM_I_INUM (j) < 0); } else if (SCM_BIGP (j)) { @@ -4991,7 +4997,7 @@ left_shift_exact_integer (SCM n, long count) else if (count < SCM_I_FIXNUM_BIT-1 && ((scm_t_bits) (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - count)) + 1) <= 1)) - return SCM_I_MAKINUM (nn << count); + return SCM_I_MAKINUM (nn < 0 ? -(-nn << count) : (nn << count)); else { SCM result = scm_i_inum2big (nn); diff --git a/libguile/numbers.h b/libguile/numbers.h index 6e382ea35..bba336bd4 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -4,7 +4,7 @@ #define SCM_NUMBERS_H /* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, - * 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. + * 2008, 2009, 2010, 2011, 2013, 2014 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 @@ -49,19 +49,43 @@ typedef scm_t_int32 scm_t_wchar; #define SCM_MOST_POSITIVE_FIXNUM ((SCM_T_SIGNED_BITS_MAX-3)/4) #define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM-1) -/* SCM_SRS is signed right shift */ -#if (-1 == (((-1) << 2) + 2) >> 2) -# define SCM_SRS(x, y) ((x) >> (y)) +/* SCM_SRS (X, Y) is signed right shift, defined as floor (X / 2^Y), + where Y must be non-negative and less than the width in bits of X. + It's common for >> to do this, but the C standards do not specify + what happens when X is negative. + + NOTE: X must not perform side effects. */ +#if (-1 >> 2 == -1) && (-4 >> 2 == -1) && (-5 >> 2 == -2) && (-8 >> 2 == -2) +# define SCM_SRS(x, y) ((x) >> (y)) #else -# define SCM_SRS(x, y) ((x) < 0 ? ~((~(x)) >> (y)) : ((x) >> (y))) -#endif /* (-1 == (((-1) << 2) + 2) >> 2) */ +# define SCM_SRS(x, y) \ + ((x) < 0 \ + ? -1 - (scm_t_signed_bits) (~(scm_t_bits)(x) >> (y)) \ + : ((x) >> (y))) +#endif + +/* The first implementation of SCM_I_INUM below depends on behavior that + is specified by GNU C but not by C standards, namely that when + casting to a signed integer of width N, the value is reduced modulo + 2^N to be within range of the type. The second implementation below + should be portable to all conforming C implementations, but may be + less efficient if the compiler is not sufficiently clever. + + NOTE: X must not perform side effects. */ +#ifdef __GNUC__ +# define SCM_I_INUM(x) (SCM_SRS ((scm_t_signed_bits) SCM_UNPACK (x), 2)) +#else +# define SCM_I_INUM(x) \ + (SCM_UNPACK (x) > LONG_MAX \ + ? -1 - (scm_t_signed_bits) (~SCM_UNPACK (x) >> 2) \ + : (scm_t_signed_bits) (SCM_UNPACK (x) >> 2)) +#endif #define SCM_I_INUMP(x) (2 & SCM_UNPACK (x)) #define SCM_I_NINUMP(x) (!SCM_I_INUMP (x)) #define SCM_I_MAKINUM(x) \ - (SCM_PACK ((((scm_t_signed_bits) (x)) << 2) + scm_tc2_int)) -#define SCM_I_INUM(x) (SCM_SRS ((scm_t_signed_bits) SCM_UNPACK (x), 2)) + (SCM_PACK ((((scm_t_bits) (x)) << 2) + scm_tc2_int)) /* SCM_FIXABLE is true if its long argument can be encoded in an SCM_INUM. */ #define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM) diff --git a/libguile/ports.c b/libguile/ports.c index 060c4fb31..5fb34248c 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1,5 +1,6 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2006, - * 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. + * 2007, 2008, 2009, 2010, 2011, 2012, 2013, + * 2014 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 @@ -70,9 +71,7 @@ #include <io.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef HAVE_SYS_IOCTL_H #include <sys/ioctl.h> diff --git a/libguile/posix.c b/libguile/posix.c index 0443f95ea..ae0f7c3c3 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1,5 +1,6 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. + * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, + * 2014 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,9 +47,7 @@ # endif #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef LIBC_H_WITH_UNISTD_H #include <libc.h> diff --git a/libguile/print.c b/libguile/print.c index b79eb3ffe..684b3d410 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1549,6 +1549,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, if (scm_is_eq (destination, SCM_BOOL_T)) { destination = port = scm_current_output_port (); + SCM_VALIDATE_OPORT_VALUE (1, destination); } else if (scm_is_false (destination)) { diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index db0b3f6c3..1b0aba406 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -20,10 +20,7 @@ # include <config.h> #endif -#ifdef HAVE_UNISTD_H -# include <unistd.h> -#endif - +#include <unistd.h> #include <string.h> #include <stdio.h> #include <assert.h> diff --git a/libguile/random.c b/libguile/random.c index 915f17feb..1ee0459de 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -1,5 +1,6 @@ /* Copyright (C) 1999, 2000, 2001, 2003, 2005, 2006, 2009, 2010, - * 2012, 2013 Free Software Foundation, Inc. + * 2012, 2013, 2014 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 @@ -31,10 +32,7 @@ #include <math.h> #include <string.h> #include <sys/types.h> - -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #include "libguile/smob.h" #include "libguile/numbers.h" @@ -257,7 +255,7 @@ scm_i_mask32 (scm_t_uint32 m) ? scm_masktab[m >> 8] << 8 | 0xff : (m < 0x1000000 ? scm_masktab[m >> 16] << 16 | 0xffff - : scm_masktab[m >> 24] << 24 | 0xffffff))); + : ((scm_t_uint32) scm_masktab[m >> 24]) << 24 | 0xffffff))); } scm_t_uint32 diff --git a/libguile/rw.c b/libguile/rw.c index 677e0d8df..75c280b4e 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2006, 2009, 2011 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2006, 2009, 2011, 2014 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 @@ -37,9 +37,7 @@ #include "libguile/modules.h" #include "libguile/strports.h" -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef HAVE_IO_H #include <io.h> #endif diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index d65dcea84..a23f151a2 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007, 2008, 2009, 2011, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, + * 2007, 2008, 2009, 2011, 2013, 2014 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,9 +33,7 @@ #include <process.h> /* for mingw */ #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef HAVE_SYS_TIME_H #include <sys/time.h> diff --git a/libguile/script.c b/libguile/script.c index 052ab8d42..63fbb0f3f 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1994-1998, 2000-2011, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1994-1998, 2000-2011, 2013, 2014 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 @@ -45,9 +46,7 @@ #include <string.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> /* for X_OK define */ -#endif #ifdef HAVE_IO_H #include <io.h> @@ -220,6 +219,21 @@ script_get_backslash (FILE *f) } #undef FUNC_NAME +/* + * Like `realloc', but free memory on failure; + * unlike `scm_realloc', return NULL, not aborts. +*/ +static void* +realloc0 (void *ptr, size_t size) +{ + void *new_ptr = realloc (ptr, size); + if (!new_ptr) + { + free (ptr); + } + return new_ptr; +} + static char * script_read_arg (FILE *f) @@ -245,7 +259,7 @@ script_read_arg (FILE *f) if (len >= size) { size = (size + 1) * 2; - buf = realloc (buf, size); + buf = realloc0 (buf, size); if (! buf) return 0; } @@ -328,9 +342,9 @@ scm_get_meta_args (int argc, char **argv) found_args: /* FIXME: we leak the result of calling script_read_arg. */ while ((narg = script_read_arg (f))) - if (!(nargv = (char **) realloc (nargv, + if (!(nargv = (char **) realloc0 (nargv, (1 + ++nargc) * sizeof (char *)))) - return 0L; + return 0L; else nargv[nargi++] = narg; fclose (f); diff --git a/libguile/simpos.c b/libguile/simpos.c index 7865da647..a657a8f09 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004, 2009, - * 2010, 2012, 2013 Free Software Foundation, Inc. + * 2010, 2012, 2013, 2014 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 @@ -40,9 +40,7 @@ #ifdef HAVE_STRING_H #include <string.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #if HAVE_SYS_WAIT_H # include <sys/wait.h> #endif diff --git a/libguile/snarf.h b/libguile/snarf.h index afc4d8f2a..d0b683308 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -4,7 +4,7 @@ #define SCM_SNARF_H /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2006, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. + * 2004, 2006, 2009, 2010, 2011, 2013, 2014 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 @@ -87,7 +87,7 @@ DOCSTRING ^^ } #define SCM_DEFINE_GSUBR(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \ SCM_SNARF_HERE(\ -static const char s_ ## FNAME [] = PRIMNAME; \ +SCM_UNUSED static const char s_ ## FNAME [] = PRIMNAME; \ SCM FNAME ARGLIST\ )\ SCM_SNARF_INIT(\ @@ -102,7 +102,7 @@ SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) #define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \ SCM_SNARF_HERE(\ -static const char s_ ## FNAME [] = PRIMNAME; \ +SCM_UNUSED static const char s_ ## FNAME [] = PRIMNAME; \ static SCM g_ ## FNAME; \ SCM FNAME ARGLIST\ )\ @@ -116,7 +116,7 @@ SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) #define SCM_DEFINE_PUBLIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \ SCM_SNARF_HERE(\ -static const char s_ ## FNAME [] = PRIMNAME; \ +SCM_UNUSED static const char s_ ## FNAME [] = PRIMNAME; \ SCM FNAME ARGLIST\ )\ SCM_SNARF_INIT(\ @@ -127,12 +127,12 @@ scm_c_export (s_ ## FNAME, NULL); \ SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) #define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ -SCM_SNARF_HERE(static const char RANAME[]=STR) \ +SCM_SNARF_HERE(SCM_UNUSED static const char RANAME[]=STR) \ SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \ (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN)) #define SCM_REGISTER_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ -SCM_SNARF_HERE(static const char RANAME[]=STR) \ +SCM_SNARF_HERE(SCM_UNUSED static const char RANAME[]=STR) \ SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \ (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN);) \ SCM_SNARF_DOCS(register, CFN, STR, (), REQ, OPT, VAR, \ @@ -140,7 +140,7 @@ SCM_SNARF_DOCS(register, CFN, STR, (), REQ, OPT, VAR, \ #define SCM_GPROC(RANAME, STR, REQ, OPT, VAR, CFN, GF) \ SCM_SNARF_HERE(\ -static const char RANAME[]=STR;\ +SCM_UNUSED static const char RANAME[]=STR;\ static SCM GF \ )SCM_SNARF_INIT(\ GF = SCM_PACK (0); /* Dirk:FIXME:: Can we safely use #f instead of 0? */ \ diff --git a/libguile/socket.c b/libguile/socket.c index 0516e5267..2a9be5471 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -33,9 +33,7 @@ #ifdef HAVE_STRING_H #include <string.h> #endif -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #include <sys/types.h> #include <sys/socket.h> #ifdef HAVE_UNIX_DOMAIN_SOCKETS @@ -66,7 +64,7 @@ #if defined (HAVE_UNIX_DOMAIN_SOCKETS) && !defined (SUN_LEN) -#define SUN_LEN(ptr) ((size_t) (((struct sockaddr_un *) 0)->sun_path) \ +#define SUN_LEN(ptr) (offsetof (struct sockaddr_un, sun_path) \ + strlen ((ptr)->sun_path)) #endif diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index d8a264c54..057664c58 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -137,12 +137,13 @@ scm_t_array_handle *h, \ size_t *lenp, ssize_t *incp) \ { \ + size_t byte_width = width * sizeof (ctype); \ if (!scm_is_bytevector (uvec) \ - || (scm_c_bytevector_length (uvec) % width)) \ + || (scm_c_bytevector_length (uvec) % byte_width)) \ scm_wrong_type_arg_msg (NULL, 0, uvec, #tag "vector"); \ scm_array_get_handle (uvec, h); \ if (lenp) \ - *lenp = scm_c_bytevector_length (uvec) / width; \ + *lenp = scm_c_bytevector_length (uvec) / byte_width; \ if (incp) \ *incp = 1; \ return ((ctype *)h->writable_elements); \ diff --git a/libguile/srfi-60.c b/libguile/srfi-60.c index 1ed3c9e81..de97cbc60 100644 --- a/libguile/srfi-60.c +++ b/libguile/srfi-60.c @@ -1,6 +1,6 @@ /* srfi-60.c --- Integers as Bits * - * Copyright (C) 2005, 2006, 2008, 2010 Free Software Foundation, Inc. + * Copyright (C) 2005, 2006, 2008, 2010, 2014 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 @@ -155,7 +155,12 @@ SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0, SCM_ASSERT_RANGE (3, end, (ee >= ss)); ww = ee - ss; - cc = scm_to_ulong (scm_modulo (count, scm_difference (end, start))); + /* we must avoid division by zero, and a field whose width is 0 or 1 + will be left unchanged anyway, so in that case we set cc to 0. */ + if (ww <= 1) + cc = 0; + else + cc = scm_to_ulong (scm_modulo (count, scm_difference (end, start))); if (SCM_I_INUMP (n)) { @@ -163,22 +168,40 @@ SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0, if (ee <= SCM_LONG_BIT-1) { - /* all within a long */ - long below = nn & ((1L << ss) - 1); /* before start */ - long above = nn & (-1L << ee); /* above end */ - long fmask = (-1L << ss) & ((1L << ee) - 1); /* field mask */ - long ff = nn & fmask; /* field */ - - return scm_from_long (above - | ((ff << cc) & fmask) - | ((ff >> (ww-cc)) & fmask) - | below); + /* Everything fits within a long. To avoid undefined behavior + when shifting negative numbers, we do all operations using + unsigned values, and then convert to signed at the end. */ + unsigned long unn = nn; + unsigned long below = unn & ((1UL << ss) - 1); /* below start */ + unsigned long above = unn & ~((1UL << ee) - 1); /* above end */ + unsigned long fmask = ((1UL << ww) - 1) << ss; /* field mask */ + unsigned long ff = unn & fmask; /* field */ + unsigned long uresult = (above + | ((ff << cc) & fmask) + | ((ff >> (ww-cc)) & fmask) + | below); + long result; + + if (uresult > LONG_MAX) + /* The high bit is set in uresult, so the result is + negative. We have to handle the conversion to signed + integer carefully, to avoid undefined behavior. First we + compute ~uresult, equivalent to (ULONG_MAX - uresult), + which will be between 0 and LONG_MAX (inclusive): exactly + the set of numbers that can be represented as both signed + and unsigned longs and thus convertible between them. We + cast that difference to a signed long and then substract + it from -1. */ + result = -1 - (long) ~uresult; + else + result = (long) uresult; + + return scm_from_long (result); } else { - /* either no movement, or a field of only 0 or 1 bits, result - unchanged, avoid creating a bignum */ - if (cc == 0 || ww <= 1) + /* if there's no movement, avoid creating a bignum. */ + if (cc == 0) return n; n = scm_i_long2big (nn); @@ -190,9 +213,8 @@ SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0, mpz_t tmp; SCM r; - /* either no movement, or in a field of only 0 or 1 bits, result - unchanged, avoid creating a new bignum */ - if (cc == 0 || ww <= 1) + /* if there's no movement, avoid creating a new bignum. */ + if (cc == 0) return n; big: @@ -209,7 +231,7 @@ SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0, mpz_mul_2exp (tmp, tmp, ss + cc); mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp); - /* field high part, count bits from end-count go to start */ + /* field low part, count bits from end-count go to start */ mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ee - cc); mpz_fdiv_r_2exp (tmp, tmp, cc); mpz_mul_2exp (tmp, tmp, ss); diff --git a/libguile/stime.c b/libguile/stime.c index c87692518..f656d886c 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2011, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, + * 2007, 2008, 2009, 2011, 2013, 2014 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 @@ -59,9 +60,7 @@ #include "libguile/validate.h" #include "libguile/stime.h" -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #ifdef HAVE_CLOCK_GETTIME diff --git a/libguile/strports.c b/libguile/strports.c index dd3bc59d4..a6a03b4eb 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2006, - * 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. + * 2009, 2010, 2011, 2012, 2013, 2014 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 @@ -27,9 +27,7 @@ #include "libguile/_scm.h" #include <stdio.h> -#ifdef HAVE_UNISTD_H #include <unistd.h> -#endif #include "libguile/bytevectors.h" #include "libguile/eval.h" diff --git a/libguile/threads.c b/libguile/threads.c index dd04f6ff9..bcf1e0d63 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1,6 +1,6 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, - * 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 - * Free Software Foundation, Inc. + * 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, + * 2014 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,9 +29,7 @@ #include "libguile/_scm.h" #include <stdlib.h> -#if HAVE_UNISTD_H #include <unistd.h> -#endif #include <stdio.h> #ifdef HAVE_STRING_H @@ -1779,14 +1777,6 @@ do_std_select (void *args) return NULL; } -#if !SCM_HAVE_SYS_SELECT_H -static int scm_std_select (int nfds, - fd_set *readfds, - fd_set *writefds, - fd_set *exceptfds, - struct timeval *timeout); -#endif - int scm_std_select (int nfds, fd_set *readfds, diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 86803fd24..3c09df21e 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1,4 +1,5 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, + * 2014 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 @@ -2481,7 +2482,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, && ((scm_t_bits) (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1) <= 1)) - RETURN (SCM_I_MAKINUM (nn << bits_to_shift)); + RETURN (SCM_I_MAKINUM (nn < 0 + ? -(-nn << bits_to_shift) + : (nn << bits_to_shift))); /* fall through */ } /* fall through */ |