From d0a77f10f23fb95a8f4b1b36d475258a6bd447b8 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 8 Feb 2014 12:35:35 -0500 Subject: Fix improper use of 'with-locale'. * test-suite/guile-test (run-tests): Use 'setlocale' with check instead of 'with-locale'. --- test-suite/guile-test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test-suite/guile-test b/test-suite/guile-test index 43ea48174..4a264b426 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -239,9 +239,10 @@ (lambda () (for-each (lambda (test) (display (string-append "Running " test "\n")) - (with-locale "C" - (with-test-prefix test - (load (test-file-name test))))) + (when (defined? 'setlocale) + (setlocale LC_ALL "C")) + (with-test-prefix test + (load (test-file-name test)))) tests)))) (if (opt 'coverage #f) (let-values (((coverage-data _) @@ -263,5 +264,4 @@ ;;; Local Variables: ;;; mode: scheme -;;; eval: (put 'with-locale 'scheme-indent-function 1) ;;; End: -- cgit v1.2.3 From b61025ce0f6f14541b23d93f14dfc60022b91ad6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 11 Feb 2014 20:59:38 +0100 Subject: guile.m4 tweaks * meta/guile.m4 (GUILE_PKG): Don't print "checking for guile 2.0" if we've already found 2.2. Print the correct effective version at the end. (GUILE_PROGS): Allow prereleases, whose micro version does not yet match the effective version. Default to the already-chosen effective version. --- meta/guile.m4 | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/meta/guile.m4 b/meta/guile.m4 index 29eccec03..441dcd4e8 100644 --- a/meta/guile.m4 +++ b/meta/guile.m4 @@ -1,6 +1,6 @@ ## Autoconf macros for working with Guile. ## -## Copyright (C) 1998,2001, 2006, 2010, 2012, 2013 Free Software Foundation, Inc. +## Copyright (C) 1998,2001, 2006, 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 @@ -77,8 +77,8 @@ AC_DEFUN([GUILE_PKG], GUILE_EFFECTIVE_VERSION="" _guile_errors="" for v in $_guile_versions_to_search; do - AC_MSG_NOTICE([checking for guile $v]) if test -z "$GUILE_EFFECTIVE_VERSION"; then + AC_MSG_NOTICE([checking for guile $v]) PKG_CHECK_EXISTS([guile-$v], [GUILE_EFFECTIVE_VERSION=$v], []) fi done @@ -93,7 +93,7 @@ the development packages. If you installed it yourself, you might need to adjust your PKG_CONFIG_PATH; see the pkg-config man page for more. ]) fi - AC_MSG_NOTICE([found guile $v]) + AC_MSG_NOTICE([found guile $GUILE_EFFECTIVE_VERSION]) AC_SUBST([GUILE_EFFECTIVE_VERSION]) ]) @@ -199,7 +199,10 @@ AC_DEFUN([GUILE_SITE_DIR], # AC_DEFUN([GUILE_PROGS], [AC_PATH_PROG(GUILE,guile) - _guile_required_version="m4_default([$1], [2.0])" + _guile_required_version="m4_default([$1], [$GUILE_EFFECTIVE_VERSION])" + if test -z "$_guile_required_version"; then + _guile_required_version=2.0 + fi if test "$GUILE" = "" ; then AC_MSG_ERROR([guile required but not found]) fi @@ -228,8 +231,11 @@ AC_DEFUN([GUILE_PROGS], AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found]) fi fi + elif test "$GUILE_EFFECTIVE_VERSION" == "$_major_version.$_minor_version" -a -z "$_micro_version"; then + # Allow prereleases that have the right effective version. + true else - AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found]) + as_fn_error $? "Guile $_guile_required_version required, but $_guile_prog_version found" "$LINENO" 5 fi else AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found]) -- cgit v1.2.3 From 5ecc58113a0a50d7a5840e9bfccce25b4f8b30ce Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 4 Feb 2014 12:18:22 -0500 Subject: REPL Server: Fix 'stop-server-and-clients!'. * module/system/repl/server.scm: Import (ice-9 match) and (srfi srfi-1). (*open-sockets*): Add comment. This is now a list of pairs with a 'force-close' procedure in the cdr. (close-socket!): Add comment noting that it is unsafe to call this from another thread. (add-open-socket!): Add 'force-close' argument, and put it in the cdr of the '*open-sockets*' entry. (stop-server-and-clients!): Use 'match'. Remove the first element from *open-sockets* immediately. Call the 'force-close' procedure instead of 'close-socket!'. (errs-to-retry): New variable. (run-server): Add a pipe, used in the 'force-close' procedure to cleanly shut down the server. Put the server socket into non-blocking mode. Use 'select' to monitor both the server socket and the pipe. Don't call 'add-open-socket!' on the client-socket. Close the pipe and the server socket cleanly when we're asked to shut down. (serve-client): Call 'add-open-socket!' with a 'force-close' procedure that cancels the thread. Set the thread cleanup handler to call 'close-socket!', instead of calling it in the main body. * doc/ref/api-evaluation.texi (REPL Servers): Add a caveat to the manual entry for 'stop-servers-and-clients!'. --- doc/ref/api-evaluation.texi | 4 ++ module/system/repl/server.scm | 98 ++++++++++++++++++++++++++++++++----------- 2 files changed, 78 insertions(+), 24 deletions(-) diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 7d67d9a21..d3e6c8cbb 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -1279,6 +1279,10 @@ with no arguments. @deffn {Scheme Procedure} stop-server-and-clients! Closes the connection on all running server sockets. + +Please note that in the current implementation, the REPL threads are +cancelled without unwinding their stacks. If any of them are holding +mutexes or are within a critical section, the results are unspecified. @end deffn @c Local Variables: diff --git a/module/system/repl/server.scm b/module/system/repl/server.scm index 4f3391c0b..5fefa77ab 100644 --- a/module/system/repl/server.scm +++ b/module/system/repl/server.scm @@ -22,34 +22,43 @@ (define-module (system repl server) #:use-module (system repl repl) #:use-module (ice-9 threads) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:export (make-tcp-server-socket make-unix-domain-server-socket run-server spawn-server stop-server-and-clients!)) +;; List of pairs of the form (SOCKET . FORCE-CLOSE), where SOCKET is a +;; socket port, and FORCE-CLOSE is a thunk that forcefully shuts down +;; the socket. (define *open-sockets* '()) (define sockets-lock (make-mutex)) +;; WARNING: it is unsafe to call 'close-socket!' from another thread. (define (close-socket! s) (with-mutex sockets-lock - (set! *open-sockets* (delq! s *open-sockets*))) + (set! *open-sockets* (assq-remove! *open-sockets* s))) ;; Close-port could block or raise an exception flushing buffered ;; output. Hmm. (close-port s)) -(define (add-open-socket! s) +(define (add-open-socket! s force-close) (with-mutex sockets-lock - (set! *open-sockets* (cons s *open-sockets*)))) + (set! *open-sockets* (acons s force-close *open-sockets*)))) (define (stop-server-and-clients!) (cond ((with-mutex sockets-lock - (and (pair? *open-sockets*) - (car *open-sockets*))) - => (lambda (s) - (close-socket! s) + (match *open-sockets* + (() #f) + (((s . force-close) . rest) + (set! *open-sockets* rest) + force-close))) + => (lambda (force-close) + (force-close) (stop-server-and-clients!))))) (define* (make-tcp-server-socket #:key @@ -67,37 +76,79 @@ (bind sock AF_UNIX path) sock)) +;; List of errno values from 'select' or 'accept' that should lead to a +;; retry in 'run-server'. +(define errs-to-retry + (delete-duplicates + (filter-map (lambda (name) + (and=> (module-variable the-root-module name) + variable-ref)) + '(EINTR EAGAIN EWOULDBLOCK)))) + (define* (run-server #:optional (server-socket (make-tcp-server-socket))) + + ;; We use a pipe to notify the server when it should shut down. + (define shutdown-pipes (pipe)) + (define shutdown-read-pipe (car shutdown-pipes)) + (define shutdown-write-pipe (cdr shutdown-pipes)) + + ;; 'shutdown-server' is called by 'stop-server-and-clients!'. + (define (shutdown-server) + (display #\! shutdown-write-pipe) + (force-output shutdown-write-pipe)) + + (define monitored-ports + (list server-socket + shutdown-read-pipe)) + (define (accept-new-client) (catch #t - (lambda () (accept server-socket)) - (lambda (k . args) - (cond - ((port-closed? server-socket) - ;; Shutting down. - #f) - (else - (warn "Error accepting client" k args) - ;; Retry after a timeout. - (sleep 1) - (accept-new-client)))))) - + (lambda () + (let ((ready-ports (car (select monitored-ports '() '())))) + ;; If we've been asked to shut down, return #f. + (and (not (memq shutdown-read-pipe ready-ports)) + (accept server-socket)))) + (lambda k-args + (let ((err (system-error-errno k-args))) + (cond + ((memv err errs-to-retry) + (accept-new-client)) + (else + (warn "Error accepting client" k-args) + ;; Retry after a timeout. + (sleep 1) + (accept-new-client))))))) + + ;; Put the socket into non-blocking mode. + (fcntl server-socket F_SETFL + (logior O_NONBLOCK + (fcntl server-socket F_GETFL))) + (sigaction SIGPIPE SIG_IGN) - (add-open-socket! server-socket) + (add-open-socket! server-socket shutdown-server) (listen server-socket 5) (let lp ((client (accept-new-client))) ;; If client is false, we are shutting down. (if client (let ((client-socket (car client)) (client-addr (cdr client))) - (add-open-socket! client-socket) (make-thread serve-client client-socket client-addr) - (lp (accept-new-client)))))) + (lp (accept-new-client))) + (begin (close shutdown-write-pipe) + (close shutdown-read-pipe) + (close server-socket))))) (define* (spawn-server #:optional (server-socket (make-tcp-server-socket))) (make-thread run-server server-socket)) (define (serve-client client addr) + + (let ((thread (current-thread))) + ;; Close the socket when this thread exits, even if canceled. + (set-thread-cleanup! thread (lambda () (close-socket! client))) + ;; Arrange to cancel this thread to forcefully shut down the socket. + (add-open-socket! client (lambda () (cancel-thread thread)))) + (with-continuation-barrier (lambda () (parameterize ((current-input-port client) @@ -105,5 +156,4 @@ (current-error-port client) (current-warning-port client)) (with-fluids ((*repl-stack* '())) - (start-repl))))) - (close-socket! client)) + (start-repl)))))) -- cgit v1.2.3 From b0a31499554fb69160b18ccefac89eec4954e488 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sun, 19 Jan 2014 13:16:02 -0500 Subject: Add cooperative REPL server module. Modified-by: Mark H Weaver * module/system/repl/coop-server.scm: New module. * module/system/repl/repl.scm (start-repl): Extract body to start-repl*. (start-repl*): New procedure. (run-repl): Extract body to run-repl*. (run-repl*): New procedure. * module/system/repl/server.scm (run-server): Extract body to run-server*. (run-server*): New procedure. * doc/ref/api-evaluation.texi (Cooperative REPL Servers): New node. * module/Makefile.am (SYSTEM_SOURCES): Add system/repl/coop-server.scm. --- doc/ref/api-evaluation.texi | 45 +++++++++ module/Makefile.am | 3 +- module/system/repl/coop-server.scm | 193 +++++++++++++++++++++++++++++++++++++ module/system/repl/repl.scm | 14 ++- module/system/repl/server.scm | 5 + 5 files changed, 257 insertions(+), 3 deletions(-) create mode 100644 module/system/repl/coop-server.scm diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index d3e6c8cbb..c441dffee 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -23,6 +23,7 @@ loading, evaluating, and compiling Scheme code at run time. * Local Evaluation:: Evaluation in a local lexical environment. * Local Inclusion:: Compile-time inclusion of one file in another. * REPL Servers:: Serving a REPL over a socket. +* Cooperative REPL Servers:: REPL server for single-threaded applications. @end menu @@ -1285,6 +1286,50 @@ cancelled without unwinding their stacks. If any of them are holding mutexes or are within a critical section, the results are unspecified. @end deffn +@node Cooperative REPL Servers +@subsection Cooperative REPL Servers + +@cindex Cooperative REPL server + +The procedures in this section are provided by +@lisp +(use-modules (system repl coop-server)) +@end lisp + +Whereas ordinary REPL servers run in their own threads (@pxref{REPL +Servers}), sometimes it is more convenient to provide REPLs that run at +specified times within an existing thread, for example in programs +utilizing an event loop or in single-threaded programs. This allows for +safe access and mutation of a program's data structures from the REPL, +without concern for thread synchronization. + +Although the REPLs are run in the thread that calls +@code{spawn-coop-repl-server} and @code{poll-coop-repl-server}, +dedicated threads are spawned so that the calling thread is not blocked. +The spawned threads read input for the REPLs and to listen for new +connections. + +Cooperative REPL servers must be polled periodically to evaluate any +pending expressions by calling @code{poll-coop-repl-server} with the +object returned from @code{spawn-coop-repl-server}. The thread that +calls @code{poll-coop-repl-server} will be blocked for as long as the +expression takes to be evaluated or if the debugger is entered. + +@deffn {Scheme Procedure} spawn-coop-repl-server [server-socket] +Create and return a new cooperative REPL server object, and spawn a new +thread to listen for connections on @var{server-socket}. Proper +functioning of the REPL server requires that +@code{poll-coop-repl-server} be called periodically on the returned +server object. +@end deffn + +@deffn {Scheme Procedure} poll-coop-repl-server coop-server +Poll the cooperative REPL server @var{coop-server} and apply a pending +operation if there is one, such as evaluating an expression typed at the +REPL prompt. This procedure must be called from the same thread that +called @code{spawn-coop-repl-server}. +@end deffn + @c Local Variables: @c TeX-master: "guile.texi" @c End: diff --git a/module/Makefile.am b/module/Makefile.am index cbdbbc9a2..5f777b6f6 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -366,7 +366,8 @@ SYSTEM_SOURCES = \ system/repl/common.scm \ system/repl/command.scm \ system/repl/repl.scm \ - system/repl/server.scm + system/repl/server.scm \ + system/repl/coop-server.scm LIB_SOURCES = \ statprof.scm \ diff --git a/module/system/repl/coop-server.scm b/module/system/repl/coop-server.scm new file mode 100644 index 000000000..c19dda191 --- /dev/null +++ b/module/system/repl/coop-server.scm @@ -0,0 +1,193 @@ +;;; Cooperative REPL server + +;; Copyright (C) 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 the License, or (at your option) any later version. +;; +;; This library 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Code: + +(define-module (system repl coop-server) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 threads) + #:use-module (ice-9 q) + #:use-module (srfi srfi-9) + #:use-module ((system repl repl) + #:select (start-repl* prompting-meta-read)) + #:use-module ((system repl server) + #:select (run-server* make-tcp-server-socket + add-open-socket! close-socket!)) + #:export (spawn-coop-repl-server + poll-coop-repl-server)) + +(define-record-type + (%make-coop-repl-server mutex queue) + coop-repl-server? + (mutex coop-repl-server-mutex) + (queue coop-repl-server-queue)) + +(define (make-coop-repl-server) + (%make-coop-repl-server (make-mutex) (make-q))) + +(define (coop-repl-server-eval coop-server opcode . args) + "Queue a new instruction with the symbolic name OPCODE and an arbitrary +number of arguments, to be processed the next time COOP-SERVER is polled." + (with-mutex (coop-repl-server-mutex coop-server) + (enq! (coop-repl-server-queue coop-server) + (cons opcode args)))) + +(define-record-type + (%make-coop-repl mutex condvar thunk cont) + coop-repl? + (mutex coop-repl-mutex) + (condvar coop-repl-condvar) ; signaled when thunk becomes non-#f + (thunk coop-repl-read-thunk set-coop-repl-read-thunk!) + (cont coop-repl-cont set-coop-repl-cont!)) + +(define (make-coop-repl) + (%make-coop-repl (make-mutex) (make-condition-variable) #f #f)) + +(define (coop-repl-read coop-repl) + "Read an expression via the thunk stored in COOP-REPL." + (let ((thunk + (with-mutex (coop-repl-mutex coop-repl) + (unless (coop-repl-read-thunk coop-repl) + (wait-condition-variable (coop-repl-condvar coop-repl) + (coop-repl-mutex coop-repl))) + (let ((thunk (coop-repl-read-thunk coop-repl))) + (unless thunk + (error "coop-repl-read: condvar signaled, but thunk is #f!")) + (set-coop-repl-read-thunk! coop-repl #f) + thunk)))) + (thunk))) + +(define (store-repl-cont cont coop-repl) + "Save the partial continuation CONT within COOP-REPL." + (set-coop-repl-cont! coop-repl + (lambda (exp) + (coop-repl-prompt + (lambda () (cont exp)))))) + +(define (coop-repl-prompt thunk) + "Apply THUNK within a prompt for cooperative REPLs." + (call-with-prompt 'coop-repl-prompt thunk store-repl-cont)) + +(define (make-coop-reader coop-repl) + "Return a new procedure for reading user input from COOP-REPL. The +generated procedure passes the responsibility of reading input to +another thread and aborts the cooperative REPL prompt." + (lambda (repl) + (let ((read-thunk + ;; Need to preserve the REPL stack and current module across + ;; threads. + (let ((stack (fluid-ref *repl-stack*)) + (module (current-module))) + (lambda () + (with-fluids ((*repl-stack* stack)) + (set-current-module module) + (prompting-meta-read repl)))))) + (with-mutex (coop-repl-mutex coop-repl) + (when (coop-repl-read-thunk coop-repl) + (error "coop-reader: read-thunk is not #f!")) + (set-coop-repl-read-thunk! coop-repl read-thunk) + (signal-condition-variable (coop-repl-condvar coop-repl)))) + (abort-to-prompt 'coop-repl-prompt coop-repl))) + +(define (reader-loop coop-server coop-repl) + "Run an unbounded loop that reads an expression for COOP-REPL and +stores the expression within COOP-SERVER for later evaluation." + (coop-repl-server-eval coop-server 'eval coop-repl + (coop-repl-read coop-repl)) + (reader-loop coop-server coop-repl)) + +(define (poll-coop-repl-server coop-server) + "Poll the cooperative REPL server COOP-SERVER and apply a pending +operation if there is one, such as evaluating an expression typed at the +REPL prompt. This procedure must be called from the same thread that +called spawn-coop-repl-server." + (let ((op (with-mutex (coop-repl-server-mutex coop-server) + (let ((queue (coop-repl-server-queue coop-server))) + (and (not (q-empty? queue)) + (deq! queue)))))) + (when op + (match op + (('new-repl client) + (start-repl-client coop-server client)) + (('eval coop-repl exp) + ((coop-repl-cont coop-repl) exp)))) + *unspecified*)) + +(define (start-coop-repl coop-server) + "Start a new cooperative REPL process for COOP-SERVER." + ;; Calling stop-server-and-clients! from a REPL will cause an + ;; exception to be thrown when trying to read from the socket that has + ;; been closed, so we catch that here. + (false-if-exception + (let ((coop-repl (make-coop-repl))) + (make-thread reader-loop coop-server coop-repl) + (start-repl* (current-language) #f (make-coop-reader coop-repl))))) + +(define (run-coop-repl-server coop-server server-socket) + "Start the cooperative REPL server for COOP-SERVER using the socket +SERVER-SOCKET." + (run-server* server-socket (make-coop-client-proc coop-server))) + +(define* (spawn-coop-repl-server + #:optional (server-socket (make-tcp-server-socket))) + "Create and return a new cooperative REPL server object, and spawn a +new thread to listen for connections on SERVER-SOCKET. Proper +functioning of the REPL server requires that poll-coop-repl-server be +called periodically on the returned server object." + (let ((coop-server (make-coop-repl-server))) + (make-thread run-coop-repl-server + coop-server + server-socket) + coop-server)) + +(define (make-coop-client-proc coop-server) + "Return a new procedure that is used to schedule the creation of a new +cooperative REPL for COOP-SERVER." + (lambda (client addr) + (coop-repl-server-eval coop-server 'new-repl client))) + +(define (start-repl-client coop-server client) + "Run a cooperative REPL for COOP-SERVER within a prompt. All input +and output is sent over the socket CLIENT." + + ;; Add the client to the list of open sockets, with a 'force-close' + ;; procedure that closes the underlying file descriptor. We do it + ;; this way because we cannot close the port itself safely from + ;; another thread. + (add-open-socket! client (lambda () (close-fdes (fileno client)))) + + (with-continuation-barrier + (lambda () + (coop-repl-prompt + (lambda () + (parameterize ((current-input-port client) + (current-output-port client) + (current-error-port client) + (current-warning-port client)) + (with-fluids ((*repl-stack* '())) + (save-module-excursion + (lambda () + (start-coop-repl coop-server))))) + + ;; This may fail if 'stop-server-and-clients!' is called, + ;; because the 'force-close' procedure above closes the + ;; underlying file descriptor instead of the port itself. + (false-if-exception + (close-socket! client))))))) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 16495560c..5b27125f1 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -1,6 +1,7 @@ ;;; Read-Eval-Print Loop -;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2001, 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 @@ -107,6 +108,8 @@ ;; to be able to re-use the existing readline machinery. ;; ;; Catches read errors, returning *unspecified* in that case. +;; +;; Note: although not exported, this is used by (system repl coop-server) (define (prompting-meta-read repl) (catch #t (lambda () @@ -129,10 +132,14 @@ ;;; (define* (start-repl #:optional (lang (current-language)) #:key debug) + (start-repl* lang debug prompting-meta-read)) + +;; Note: although not exported, this is used by (system repl coop-server) +(define (start-repl* lang debug prompting-meta-read) ;; ,language at the REPL will update the current-language. Make ;; sure that it does so in a new dynamic scope. (parameterize ((current-language lang)) - (run-repl (make-repl lang debug)))) + (run-repl* (make-repl lang debug) prompting-meta-read))) ;; (put 'abort-on-error 'scheme-indent-function 1) (define-syntax-rule (abort-on-error string exp) @@ -144,6 +151,9 @@ (abort)))) (define (run-repl repl) + (run-repl* repl prompting-meta-read)) + +(define (run-repl* repl prompting-meta-read) (define (with-stack-and-prompt thunk) (call-with-prompt (default-prompt-tag) (lambda () (start-stack #t (thunk))) diff --git a/module/system/repl/server.scm b/module/system/repl/server.scm index 5fefa77ab..ff9ee5cbc 100644 --- a/module/system/repl/server.scm +++ b/module/system/repl/server.scm @@ -38,6 +38,7 @@ (define sockets-lock (make-mutex)) ;; WARNING: it is unsafe to call 'close-socket!' from another thread. +;; Note: although not exported, this is used by (system repl coop-server) (define (close-socket! s) (with-mutex sockets-lock (set! *open-sockets* (assq-remove! *open-sockets* s))) @@ -45,6 +46,7 @@ ;; output. Hmm. (close-port s)) +;; Note: although not exported, this is used by (system repl coop-server) (define (add-open-socket! s force-close) (with-mutex sockets-lock (set! *open-sockets* (acons s force-close *open-sockets*)))) @@ -86,7 +88,10 @@ '(EINTR EAGAIN EWOULDBLOCK)))) (define* (run-server #:optional (server-socket (make-tcp-server-socket))) + (run-server* server-socket serve-client)) +;; Note: although not exported, this is used by (system repl coop-server) +(define (run-server* server-socket serve-client) ;; We use a pipe to notify the server when it should shut down. (define shutdown-pipes (pipe)) (define shutdown-read-pipe (car shutdown-pipes)) -- cgit v1.2.3 From f9d4a040b4719fca2a433c01b680679d155ec981 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 12 Feb 2014 17:43:35 -0500 Subject: Import 'lstat' and 'mkstemp' modules from Gnulib. * lib/mkstemp.c: * lib/secure_getenv.c: * lib/tempname.c: * lib/tempname.h: * m4/mkstemp.m4: * m4/secure_getenv.m4: * m4/tempname.m4: New files. * lib/Makefile.am: * m4/gnulib-cache.m4: * m4/gnulib-comp.m4: Add modules. --- lib/Makefile.am | 28 ++++- lib/mkstemp.c | 50 +++++++++ lib/secure_getenv.c | 41 +++++++ lib/tempname.c | 306 ++++++++++++++++++++++++++++++++++++++++++++++++++++ lib/tempname.h | 50 +++++++++ m4/gnulib-cache.m4 | 4 +- m4/gnulib-comp.m4 | 23 ++++ m4/mkstemp.m4 | 82 ++++++++++++++ m4/secure_getenv.m4 | 25 +++++ m4/tempname.m4 | 19 ++++ 10 files changed, 626 insertions(+), 2 deletions(-) create mode 100644 lib/mkstemp.c create mode 100644 lib/secure_getenv.c create mode 100644 lib/tempname.c create mode 100644 lib/tempname.h create mode 100644 m4/mkstemp.m4 create mode 100644 m4/secure_getenv.m4 create mode 100644 m4/tempname.m4 diff --git a/lib/Makefile.am b/lib/Makefile.am index 564836953..18cb5e3bb 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 poll putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc verify vsnprintf warnings wchar AUTOMAKE_OPTIONS = 1.9.6 gnits subdir-objects @@ -1417,6 +1417,15 @@ EXTRA_libgnu_la_SOURCES += memchr.c ## end gnulib module memchr +## begin gnulib module mkstemp + + +EXTRA_DIST += mkstemp.c + +EXTRA_libgnu_la_SOURCES += mkstemp.c + +## end gnulib module mkstemp + ## begin gnulib module msvc-inval @@ -1701,6 +1710,15 @@ EXTRA_DIST += same-inode.h ## end gnulib module same-inode +## begin gnulib module secure_getenv + + +EXTRA_DIST += secure_getenv.c + +EXTRA_libgnu_la_SOURCES += secure_getenv.c + +## end gnulib module secure_getenv + ## begin gnulib module select @@ -2737,6 +2755,14 @@ EXTRA_DIST += sys_uio.in.h ## end gnulib module sys_uio +## begin gnulib module tempname + +libgnu_la_SOURCES += tempname.c + +EXTRA_DIST += tempname.h + +## end gnulib module tempname + ## begin gnulib module threadlib libgnu_la_SOURCES += glthread/threadlib.c diff --git a/lib/mkstemp.c b/lib/mkstemp.c new file mode 100644 index 000000000..0af69f9c3 --- /dev/null +++ b/lib/mkstemp.c @@ -0,0 +1,50 @@ +/* Copyright (C) 1998-1999, 2001, 2005-2007, 2009-2014 Free Software + Foundation, Inc. + This file is derived from the one in the GNU C Library. + + This program 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 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#if !_LIBC +# include +#endif + +#include + +#if !_LIBC +# include "tempname.h" +# define __gen_tempname gen_tempname +# ifndef __GT_FILE +# define __GT_FILE GT_FILE +# endif +#endif + +#include + +#ifndef __GT_FILE +# define __GT_FILE 0 +#endif + +/* Generate a unique temporary file name from XTEMPLATE. + The last six characters of XTEMPLATE must be "XXXXXX"; + they are replaced with a string that makes the file name unique. + Then open the file and return a fd. + + If you are creating temporary files which will later be removed, + consider using the clean-temp module, which avoids several pitfalls + of using mkstemp directly. */ +int +mkstemp (char *xtemplate) +{ + return __gen_tempname (xtemplate, 0, 0, __GT_FILE); +} diff --git a/lib/secure_getenv.c b/lib/secure_getenv.c new file mode 100644 index 000000000..7b86173bb --- /dev/null +++ b/lib/secure_getenv.c @@ -0,0 +1,41 @@ +/* Look up an environment variable more securely. + + Copyright 2013-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 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +#include + +#if !HAVE___SECURE_GETENV +# if HAVE_ISSETUGID +# include +# else +# undef issetugid +# define issetugid() 1 +# endif +#endif + +char * +secure_getenv (char const *name) +{ +#if HAVE___SECURE_GETENV + return __secure_getenv (name); +#else + if (issetugid ()) + return 0; + return getenv (name); +#endif +} diff --git a/lib/tempname.c b/lib/tempname.c new file mode 100644 index 000000000..f0f7e7f29 --- /dev/null +++ b/lib/tempname.c @@ -0,0 +1,306 @@ +/* tempname.c - generate the name of a temporary file. + + Copyright (C) 1991-2003, 2005-2007, 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 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +/* Extracted from glibc sysdeps/posix/tempname.c. See also tmpdir.c. */ + +#if !_LIBC +# include +# include "tempname.h" +#endif + +#include +#include + +#include +#ifndef __set_errno +# define __set_errno(Val) errno = (Val) +#endif + +#include +#ifndef P_tmpdir +# define P_tmpdir "/tmp" +#endif +#ifndef TMP_MAX +# define TMP_MAX 238328 +#endif +#ifndef __GT_FILE +# define __GT_FILE 0 +# define __GT_DIR 1 +# define __GT_NOCREATE 2 +#endif +#if !_LIBC && (GT_FILE != __GT_FILE || GT_DIR != __GT_DIR \ + || GT_NOCREATE != __GT_NOCREATE) +# error report this to bug-gnulib@gnu.org +#endif + +#include +#include +#include + +#include +#include +#include +#include + +#include + +#if _LIBC +# define struct_stat64 struct stat64 +#else +# define struct_stat64 struct stat +# define __gen_tempname gen_tempname +# define __getpid getpid +# define __gettimeofday gettimeofday +# define __mkdir mkdir +# define __open open +# define __lxstat64(version, file, buf) lstat (file, buf) +# define __secure_getenv secure_getenv +#endif + +#ifdef _LIBC +# include +# if HP_TIMING_AVAIL +# define RANDOM_BITS(Var) \ + if (__builtin_expect (value == UINT64_C (0), 0)) \ + { \ + /* If this is the first time this function is used initialize \ + the variable we accumulate the value in to some somewhat \ + random value. If we'd not do this programs at startup time \ + might have a reduced set of possible names, at least on slow \ + machines. */ \ + struct timeval tv; \ + __gettimeofday (&tv, NULL); \ + value = ((uint64_t) tv.tv_usec << 16) ^ tv.tv_sec; \ + } \ + HP_TIMING_NOW (Var) +# endif +#endif + +/* Use the widest available unsigned type if uint64_t is not + available. The algorithm below extracts a number less than 62**6 + (approximately 2**35.725) from uint64_t, so ancient hosts where + uintmax_t is only 32 bits lose about 3.725 bits of randomness, + which is better than not having mkstemp at all. */ +#if !defined UINT64_MAX && !defined uint64_t +# define uint64_t uintmax_t +#endif + +#if _LIBC +/* Return nonzero if DIR is an existent directory. */ +static int +direxists (const char *dir) +{ + struct_stat64 buf; + return __xstat64 (_STAT_VER, dir, &buf) == 0 && S_ISDIR (buf.st_mode); +} + +/* Path search algorithm, for tmpnam, tmpfile, etc. If DIR is + non-null and exists, uses it; otherwise uses the first of $TMPDIR, + P_tmpdir, /tmp that exists. Copies into TMPL a template suitable + for use with mk[s]temp. Will fail (-1) if DIR is non-null and + doesn't exist, none of the searched dirs exists, or there's not + enough space in TMPL. */ +int +__path_search (char *tmpl, size_t tmpl_len, const char *dir, const char *pfx, + int try_tmpdir) +{ + const char *d; + size_t dlen, plen; + + if (!pfx || !pfx[0]) + { + pfx = "file"; + plen = 4; + } + else + { + plen = strlen (pfx); + if (plen > 5) + plen = 5; + } + + if (try_tmpdir) + { + d = __secure_getenv ("TMPDIR"); + if (d != NULL && direxists (d)) + dir = d; + else if (dir != NULL && direxists (dir)) + /* nothing */ ; + else + dir = NULL; + } + if (dir == NULL) + { + if (direxists (P_tmpdir)) + dir = P_tmpdir; + else if (strcmp (P_tmpdir, "/tmp") != 0 && direxists ("/tmp")) + dir = "/tmp"; + else + { + __set_errno (ENOENT); + return -1; + } + } + + dlen = strlen (dir); + while (dlen > 1 && dir[dlen - 1] == '/') + dlen--; /* remove trailing slashes */ + + /* check we have room for "${dir}/${pfx}XXXXXX\0" */ + if (tmpl_len < dlen + 1 + plen + 6 + 1) + { + __set_errno (EINVAL); + return -1; + } + + sprintf (tmpl, "%.*s/%.*sXXXXXX", (int) dlen, dir, (int) plen, pfx); + return 0; +} +#endif /* _LIBC */ + +/* These are the characters used in temporary file names. */ +static const char letters[] = +"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"; + +/* Generate a temporary file name based on TMPL. TMPL must match the + rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix). + The name constructed does not exist at the time of the call to + __gen_tempname. TMPL is overwritten with the result. + + KIND may be one of: + __GT_NOCREATE: simply verify that the name does not exist + at the time of the call. + __GT_FILE: create the file using open(O_CREAT|O_EXCL) + and return a read-write fd. The file is mode 0600. + __GT_DIR: create a directory, which will be mode 0700. + + We use a clever algorithm to get hard-to-predict names. */ +int +__gen_tempname (char *tmpl, int suffixlen, int flags, int kind) +{ + int len; + char *XXXXXX; + static uint64_t value; + uint64_t random_time_bits; + unsigned int count; + int fd = -1; + int save_errno = errno; + struct_stat64 st; + + /* A lower bound on the number of temporary files to attempt to + generate. The maximum total number of temporary file names that + can exist for a given template is 62**6. It should never be + necessary to try all of these combinations. Instead if a reasonable + number of names is tried (we define reasonable as 62**3) fail to + give the system administrator the chance to remove the problems. */ +#define ATTEMPTS_MIN (62 * 62 * 62) + + /* The number of times to attempt to generate a temporary file. To + conform to POSIX, this must be no smaller than TMP_MAX. */ +#if ATTEMPTS_MIN < TMP_MAX + unsigned int attempts = TMP_MAX; +#else + unsigned int attempts = ATTEMPTS_MIN; +#endif + + len = strlen (tmpl); + if (len < 6 + suffixlen || memcmp (&tmpl[len - 6 - suffixlen], "XXXXXX", 6)) + { + __set_errno (EINVAL); + return -1; + } + + /* This is where the Xs start. */ + XXXXXX = &tmpl[len - 6 - suffixlen]; + + /* Get some more or less random data. */ +#ifdef RANDOM_BITS + RANDOM_BITS (random_time_bits); +#else + { + struct timeval tv; + __gettimeofday (&tv, NULL); + random_time_bits = ((uint64_t) tv.tv_usec << 16) ^ tv.tv_sec; + } +#endif + value += random_time_bits ^ __getpid (); + + for (count = 0; count < attempts; value += 7777, ++count) + { + uint64_t v = value; + + /* Fill in the random bits. */ + XXXXXX[0] = letters[v % 62]; + v /= 62; + XXXXXX[1] = letters[v % 62]; + v /= 62; + XXXXXX[2] = letters[v % 62]; + v /= 62; + XXXXXX[3] = letters[v % 62]; + v /= 62; + XXXXXX[4] = letters[v % 62]; + v /= 62; + XXXXXX[5] = letters[v % 62]; + + switch (kind) + { + case __GT_FILE: + fd = __open (tmpl, + (flags & ~O_ACCMODE) + | O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR); + break; + + case __GT_DIR: + fd = __mkdir (tmpl, S_IRUSR | S_IWUSR | S_IXUSR); + break; + + case __GT_NOCREATE: + /* This case is backward from the other three. __gen_tempname + succeeds if __xstat fails because the name does not exist. + Note the continue to bypass the common logic at the bottom + of the loop. */ + if (__lxstat64 (_STAT_VER, tmpl, &st) < 0) + { + if (errno == ENOENT) + { + __set_errno (save_errno); + return 0; + } + else + /* Give up now. */ + return -1; + } + continue; + + default: + assert (! "invalid KIND in __gen_tempname"); + abort (); + } + + if (fd >= 0) + { + __set_errno (save_errno); + return fd; + } + else if (errno != EEXIST) + return -1; + } + + /* We got out of the loop because we ran out of combinations to try. */ + __set_errno (EEXIST); + return -1; +} diff --git a/lib/tempname.h b/lib/tempname.h new file mode 100644 index 000000000..bd46f93f9 --- /dev/null +++ b/lib/tempname.h @@ -0,0 +1,50 @@ +/* Create a temporary file or directory. + + Copyright (C) 2006, 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 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +/* header written by Eric Blake */ + +#ifndef GL_TEMPNAME_H +# define GL_TEMPNAME_H + +# include + +# ifdef __GT_FILE +# define GT_FILE __GT_FILE +# define GT_DIR __GT_DIR +# define GT_NOCREATE __GT_NOCREATE +# else +# define GT_FILE 0 +# define GT_DIR 1 +# define GT_NOCREATE 2 +# endif + +/* Generate a temporary file name based on TMPL. TMPL must match the + rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix). + The name constructed does not exist at the time of the call to + gen_tempname. TMPL is overwritten with the result. + + KIND may be one of: + GT_NOCREATE: simply verify that the name does not exist + at the time of the call. + GT_FILE: create a large file using open(O_CREAT|O_EXCL) + and return a read-write fd. The file is mode 0600. + GT_DIR: create a directory, which will be mode 0700. + + We use a clever algorithm to get hard-to-predict names. */ +extern int gen_tempname (char *tmpl, int suffixlen, int flags, int kind); + +#endif /* GL_TEMPNAME_H */ diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index ecbfd736c..3c3c65d85 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -27,7 +27,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 poll putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc verify vsnprintf warnings wchar +# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) @@ -83,9 +83,11 @@ gl_MODULES([ localcharset locale log1p + lstat maintainer-makefile malloc-gnu malloca + mkstemp nl_langinfo nproc open diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index a18870900..74a51f79e 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -144,6 +144,7 @@ AC_DEFUN([gl_EARLY], # Code from module mbsinit: # Code from module mbtowc: # Code from module memchr: + # Code from module mkstemp: # Code from module msvc-inval: # Code from module msvc-nothrow: # Code from module multiarch: @@ -171,6 +172,7 @@ AC_DEFUN([gl_EARLY], # Code from module safe-read: # Code from module safe-write: # Code from module same-inode: + # Code from module secure_getenv: # Code from module select: # Code from module send: # Code from module sendto: @@ -212,6 +214,7 @@ AC_DEFUN([gl_EARLY], # Code from module sys_times: # Code from module sys_types: # Code from module sys_uio: + # Code from module tempname: # Code from module threadlib: gl_THREADLIB_EARLY # Code from module time: @@ -567,6 +570,12 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_MEMCHR fi gl_STRING_MODULE_INDICATOR([memchr]) + gl_FUNC_MKSTEMP + if test $HAVE_MKSTEMP = 0 || test $REPLACE_MKSTEMP = 1; then + AC_LIBOBJ([mkstemp]) + gl_PREREQ_MKSTEMP + fi + gl_STDLIB_MODULE_INDICATOR([mkstemp]) gl_MSVC_INVAL if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then AC_LIBOBJ([msvc-inval]) @@ -662,6 +671,12 @@ AC_SUBST([LTALLOCA]) gl_MATH_MODULE_INDICATOR([round]) gl_PREREQ_SAFE_READ gl_PREREQ_SAFE_WRITE + gl_FUNC_SECURE_GETENV + if test $HAVE_SECURE_GETENV = 0; then + AC_LIBOBJ([secure_getenv]) + gl_PREREQ_SECURE_GETENV + fi + gl_STDLIB_MODULE_INDICATOR([secure_getenv]) gl_FUNC_SELECT if test $REPLACE_SELECT = 1; then AC_LIBOBJ([select]) @@ -759,6 +774,7 @@ AC_SUBST([LTALLOCA]) AC_PROG_MKDIR_P gl_HEADER_SYS_UIO AC_PROG_MKDIR_P + gl_FUNC_GEN_TEMPNAME gl_THREADLIB gl_HEADER_TIME_H gl_TIME_R @@ -1059,6 +1075,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/mbtowc.c lib/memchr.c lib/memchr.valgrind + lib/mkstemp.c lib/msvc-inval.c lib/msvc-inval.h lib/msvc-nothrow.c @@ -1100,6 +1117,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/safe-write.c lib/safe-write.h lib/same-inode.h + lib/secure_getenv.c lib/select.c lib/send.c lib/sendto.c @@ -1140,6 +1158,8 @@ AC_DEFUN([gl_FILE_LIST], [ lib/sys_times.in.h lib/sys_types.in.h lib/sys_uio.in.h + lib/tempname.c + lib/tempname.h lib/time.in.h lib/time_r.c lib/times.c @@ -1257,6 +1277,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/mbstate_t.m4 m4/mbtowc.m4 m4/memchr.m4 + m4/mkstemp.m4 m4/mmap-anon.m4 m4/mode_t.m4 m4/msvc-inval.m4 @@ -1285,6 +1306,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/round.m4 m4/safe-read.m4 m4/safe-write.m4 + m4/secure_getenv.m4 m4/select.m4 m4/servent.m4 m4/setenv.m4 @@ -1316,6 +1338,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/sys_times_h.m4 m4/sys_types_h.m4 m4/sys_uio_h.m4 + m4/tempname.m4 m4/threadlib.m4 m4/time_h.m4 m4/time_r.m4 diff --git a/m4/mkstemp.m4 b/m4/mkstemp.m4 new file mode 100644 index 000000000..9033a4e60 --- /dev/null +++ b/m4/mkstemp.m4 @@ -0,0 +1,82 @@ +#serial 23 + +# Copyright (C) 2001, 2003-2007, 2009-2014 Free Software Foundation, Inc. +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# On some hosts (e.g., HP-UX 10.20, SunOS 4.1.4, Solaris 2.5.1), mkstemp has a +# silly limit that it can create no more than 26 files from a given template. +# Other systems lack mkstemp altogether. +# On OSF1/Tru64 V4.0F, the system-provided mkstemp function can create +# only 32 files per process. +# On some hosts, mkstemp creates files with mode 0666, which is a security +# problem and a violation of POSIX 2008. +# On systems like the above, arrange to use the replacement function. +AC_DEFUN([gl_FUNC_MKSTEMP], +[ + AC_REQUIRE([gl_STDLIB_H_DEFAULTS]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + + AC_CHECK_FUNCS_ONCE([mkstemp]) + if test $ac_cv_func_mkstemp = yes; then + AC_CACHE_CHECK([for working mkstemp], + [gl_cv_func_working_mkstemp], + [ + mkdir conftest.mkstemp + AC_RUN_IFELSE( + [AC_LANG_PROGRAM( + [AC_INCLUDES_DEFAULT], + [[int result = 0; + int i; + off_t large = (off_t) 4294967295u; + if (large < 0) + large = 2147483647; + umask (0); + for (i = 0; i < 70; i++) + { + char templ[] = "conftest.mkstemp/coXXXXXX"; + int (*mkstemp_function) (char *) = mkstemp; + int fd = mkstemp_function (templ); + if (fd < 0) + result |= 1; + else + { + struct stat st; + if (lseek (fd, large, SEEK_SET) != large) + result |= 2; + if (fstat (fd, &st) < 0) + result |= 4; + else if (st.st_mode & 0077) + result |= 8; + if (close (fd)) + result |= 16; + } + } + return result;]])], + [gl_cv_func_working_mkstemp=yes], + [gl_cv_func_working_mkstemp=no], + [case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_working_mkstemp="guessing yes" ;; + # If we don't know, assume the worst. + *) gl_cv_func_working_mkstemp="guessing no" ;; + esac + ]) + rm -rf conftest.mkstemp + ]) + case "$gl_cv_func_working_mkstemp" in + *yes) ;; + *) + REPLACE_MKSTEMP=1 + ;; + esac + else + HAVE_MKSTEMP=0 + fi +]) + +# Prerequisites of lib/mkstemp.c. +AC_DEFUN([gl_PREREQ_MKSTEMP], +[ +]) diff --git a/m4/secure_getenv.m4 b/m4/secure_getenv.m4 new file mode 100644 index 000000000..149888df4 --- /dev/null +++ b/m4/secure_getenv.m4 @@ -0,0 +1,25 @@ +# Look up an environment variable more securely. +dnl Copyright 2013-2014 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FUNC_SECURE_GETENV], +[ + dnl Persuade glibc to declare secure_getenv(). + AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) + + AC_REQUIRE([gl_STDLIB_H_DEFAULTS]) + AC_CHECK_FUNCS_ONCE([secure_getenv]) + if test $ac_cv_func_secure_getenv = no; then + HAVE_SECURE_GETENV=0 + fi +]) + +# Prerequisites of lib/secure_getenv.c. +AC_DEFUN([gl_PREREQ_SECURE_GETENV], [ + AC_CHECK_FUNCS([__secure_getenv]) + if test $ac_cv_func___secure_getenv = no; then + AC_CHECK_FUNCS([issetugid]) + fi +]) diff --git a/m4/tempname.m4 b/m4/tempname.m4 new file mode 100644 index 000000000..1594e1f5d --- /dev/null +++ b/m4/tempname.m4 @@ -0,0 +1,19 @@ +#serial 5 + +# Copyright (C) 2006-2007, 2009-2014 Free Software Foundation, Inc. +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# glibc provides __gen_tempname as a wrapper for mk[ds]temp. Expose +# it as a public API, and provide it on systems that are lacking. +AC_DEFUN([gl_FUNC_GEN_TEMPNAME], +[ + gl_PREREQ_TEMPNAME +]) + +# Prerequisites of lib/tempname.c. +AC_DEFUN([gl_PREREQ_TEMPNAME], +[ + : +]) -- cgit v1.2.3 From e1d7a93bb286d691069d47063d1ce5baabd7a35d Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 12 Feb 2014 17:47:13 -0500 Subject: Rely on Gnulib for 'select', 'lstat', and 'mkstemp'. * libguile/iselect.h: * libguile/threads.c: * libguile/deprecated.h: Rely on Gnulib for sys/select.h. * libguile/filesys.c: Rely on Gnulib for 'lstat' and 'mkstemp'. --- libguile/deprecated.h | 2 -- libguile/filesys.c | 6 ------ libguile/iselect.h | 4 ---- libguile/threads.c | 8 -------- 4 files changed, 20 deletions(-) diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 5f95f2711..4d7819761 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -742,13 +742,11 @@ SCM_DEPRECATED SCM scm_c_make_keyword (const char *s); SCM_DEPRECATED unsigned int scm_thread_sleep (unsigned int); SCM_DEPRECATED unsigned long scm_thread_usleep (unsigned long); -#if SCM_HAVE_SYS_SELECT_H SCM_DEPRECATED int scm_internal_select (int fds, fd_set *rfds, fd_set *wfds, fd_set *efds, struct timeval *timeout); -#endif /* Deprecated because the cuserid call is deprecated. */ diff --git a/libguile/filesys.c b/libguile/filesys.c index 5f6208d82..c261928f5 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -561,7 +561,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" @@ -584,7 +583,6 @@ SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, return scm_stat2scm (&stat_temp); } #undef FUNC_NAME -#endif /* HAVE_LSTAT */ #ifdef HAVE_POSIX @@ -1467,10 +1465,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/iselect.h b/libguile/iselect.h index 092fb07bf..1272b8d27 100644 --- a/libguile/iselect.h +++ b/libguile/iselect.h @@ -28,8 +28,6 @@ /* Needed for FD_SET on some systems. */ #include -#if SCM_HAVE_SYS_SELECT_H - #include SCM_API int scm_std_select (int fds, @@ -40,8 +38,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/threads.c b/libguile/threads.c index b84ddbdd6..8fddbce89 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1884,14 +1884,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, -- cgit v1.2.3 From f07fa851505c6f4e7040b10ca0e178901bd106ef Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 12 Feb 2014 14:28:03 -0500 Subject: Fix inline asm of VM numerical operations for x32. * libguile/vm-i-scheme.c (_CX): Choose register size based on 'SIZEOF_VOID_P' instead of '__x86_64__'. --- libguile/vm-i-scheme.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index fc32ec5a8..dd2150ddc 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -236,10 +236,12 @@ VM_DEFINE_FUNCTION (149, ge, "ge?", 2) #if SCM_GNUC_PREREQ (4, 5) && (defined __x86_64__ || defined __i386__) # undef _CX -# ifdef __x86_64__ +# if SIZEOF_VOID_P == 8 # define _CX "rcx" -# else +# elif SIZEOF_VOID_P == 4 # define _CX "ecx" +# else +# error unsupported word size # endif /* The macros below check the CPU's overflow flag to improve fixnum -- cgit v1.2.3 From 5f4b817df92b30ae32f934f3c2cf83a5990e1895 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 18 Feb 2014 23:04:01 +0100 Subject: Add (system base types). * module/system/base/types.scm, test-suite/tests/types.test: New files. * module/Makefile.am (SYSTEM_BASE_SOURCES): Add system/base/types.scm. * test-suite/Makefile.am (SCM_TESTS): Add tests/types.test. --- module/Makefile.am | 1 + module/system/base/types.scm | 519 +++++++++++++++++++++++++++++++++++++++++++ test-suite/Makefile.am | 1 + test-suite/tests/types.test | 154 +++++++++++++ 4 files changed, 675 insertions(+) create mode 100644 module/system/base/types.scm create mode 100644 test-suite/tests/types.test diff --git a/module/Makefile.am b/module/Makefile.am index 5f777b6f6..fb9174b52 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -188,6 +188,7 @@ SYSTEM_BASE_SOURCES = \ system/base/lalr.scm \ system/base/message.scm \ system/base/target.scm \ + system/base/types.scm \ system/base/ck.scm ICE_9_SOURCES = \ diff --git a/module/system/base/types.scm b/module/system/base/types.scm new file mode 100644 index 000000000..ed95347c4 --- /dev/null +++ b/module/system/base/types.scm @@ -0,0 +1,519 @@ +;;; 'SCM' type tag decoding. +;;; Copyright (C) 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 the License, or (at +;;; your option) any later version. +;;; +;;; This library 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 Lesser +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public License +;;; along with this program. If not, see . + +(define-module (system base types) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-60) + #:use-module (ice-9 match) + #:use-module (ice-9 iconv) + #:use-module (ice-9 format) + #:use-module (ice-9 vlist) + #:use-module (system foreign) + #:export (%word-size + + memory-backend + memory-backend? + %ffi-memory-backend + dereference-word + memory-port + type-number->name + + inferior-object? + inferior-object-kind + inferior-object-sub-kind + inferior-object-address + + inferior-fluid? + inferior-fluid-number + + inferior-struct? + inferior-struct-name + inferior-struct-fields + + scm->object)) + +;;; Commentary: +;;; +;;; 'SCM' type tag decoding, primarily to support Guile debugging in GDB. +;;; +;;; Code: + + +;;; +;;; Memory back-ends. +;;; + +(define %word-size + ;; The pointer size. + (sizeof '*)) + +(define-record-type + (memory-backend peek open type-name) + memory-backend? + (peek memory-backend-peek) + (open memory-backend-open) + (type-name memory-backend-type-name)) ; for SMOBs and ports + +(define %ffi-memory-backend + ;; The FFI back-end to access the current process's memory. The main + ;; purpose of this back-end is to allow testing. + (let () + (define (dereference-word address) + (let* ((ptr (make-pointer address)) + (bv (pointer->bytevector ptr %word-size))) + (bytevector-uint-ref bv 0 (native-endianness) %word-size))) + + (define (open address size) + (define current-address address) + + (define (read-memory! bv index count) + (let* ((ptr (make-pointer current-address)) + (mem (pointer->bytevector ptr count))) + (bytevector-copy! mem 0 bv index count) + (set! current-address (+ current-address count)) + count)) + + (if size + (let* ((ptr (make-pointer address)) + (bv (pointer->bytevector ptr size))) + (open-bytevector-input-port bv)) + (let ((port (make-custom-binary-input-port "ffi-memory" + read-memory! + #f #f #f))) + (setvbuf port _IONBF) + port))) + + (memory-backend dereference-word open #f))) + +(define-inlinable (dereference-word backend address) + "Return the word at ADDRESS, using BACKEND." + (let ((peek (memory-backend-peek backend))) + (peek address))) + +(define-syntax memory-port + (syntax-rules () + "Return an input port to the SIZE bytes at ADDRESS, using BACKEND. When +SIZE is omitted, return an unbounded port to the memory at ADDRESS." + ((_ backend address) + (let ((open (memory-backend-open backend))) + (open address #f))) + ((_ backend address size) + (let ((open (memory-backend-open backend))) + (open address size))))) + +(define (get-word port) + "Read a word from PORT and return it as an integer." + (let ((bv (get-bytevector-n port %word-size))) + (bytevector-uint-ref bv 0 (native-endianness) %word-size))) + +(define-inlinable (type-number->name backend kind number) + "Return the name of the type NUMBER of KIND, where KIND is one of +'smob or 'port, or #f if the information is unavailable." + (let ((proc (memory-backend-type-name backend))) + (and proc (proc kind number)))) + + +;;; +;;; Matching bit patterns and cells. +;;; + +(define-syntax match-cell-words + (syntax-rules (bytevector) + ((_ port ((bytevector name len) rest ...) body) + (let ((name (get-bytevector-n port len)) + (remainder (modulo len %word-size))) + (unless (zero? remainder) + (get-bytevector-n port (- %word-size remainder))) + (match-cell-words port (rest ...) body))) + ((_ port (name rest ...) body) + (let ((name (get-word port))) + (match-cell-words port (rest ...) body))) + ((_ port () body) + body))) + +(define-syntax match-bit-pattern + (syntax-rules (& || = _) + ((match-bit-pattern bits ((a || b) & n = c) consequent alternate) + (let ((tag (logand bits n))) + (if (= tag c) + (let ((b tag) + (a (logand bits (bitwise-not n)))) + consequent) + alternate))) + ((match-bit-pattern bits (x & n = c) consequent alternate) + (let ((tag (logand bits n))) + (if (= tag c) + (let ((x bits)) + consequent) + alternate))) + ((match-bit-pattern bits (_ & n = c) consequent alternate) + (let ((tag (logand bits n))) + (if (= tag c) + consequent + alternate))) + ((match-bit-pattern bits ((a << n) || c) consequent alternate) + (let ((tag (bitwise-and bits (- (expt 2 n) 1)))) + (if (= tag c) + (let ((a (arithmetic-shift bits (- n)))) + consequent) + alternate))))) + +(define-syntax match-cell-clauses + (syntax-rules () + ((_ port tag (((tag-pattern thing ...) body) rest ...)) + (match-bit-pattern tag tag-pattern + (match-cell-words port (thing ...) body) + (match-cell-clauses port tag (rest ...)))) + ((_ port tag ()) + (inferior-object 'unmatched-tag tag)))) + +(define-syntax match-cell + (syntax-rules () + "Match a cell---i.e., a non-immediate value other than a pair. The +cell's contents are read from PORT." + ((_ port (pattern body ...) ...) + (let ((port* port) + (tag (get-word port))) + (match-cell-clauses port* tag + ((pattern (begin body ...)) + ...)))))) + +(define-syntax match-scm-clauses + (syntax-rules () + ((_ bits + (bit-pattern body ...) + rest ...) + (match-bit-pattern bits bit-pattern + (begin body ...) + (match-scm-clauses bits rest ...))) + ((_ bits) + 'unmatched-scm))) + +(define-syntax match-scm + (syntax-rules () + "Match BITS, an integer representation of an 'SCM' value, against +CLAUSES. Each clause must have the form: + + (PATTERN BODY ...) + +PATTERN is a bit pattern that may specify bitwise operations on BITS to +determine if it matches. TEMPLATE specify the name of the variable to bind +the matching bits, possibly with bitwise operations to extract it from BITS." + ((_ bits clauses ...) + (let ((bits* bits)) + (match-scm-clauses bits* clauses ...))))) + + +;;; +;;; Tags---keep in sync with libguile/tags.h! +;;; + +;; Immediate values. +(define %tc2-int 2) +(define %tc3-imm24 4) + +(define %tc3-cons 0) +(define %tc3-int1 %tc2-int) +(define %tc3-int2 (+ %tc2-int 4)) + +(define %tc8-char (+ 8 %tc3-imm24)) +(define %tc8-flag (+ %tc3-imm24 0)) + +;; Cell types. +(define %tc3-struct 1) +(define %tc7-symbol 5) +(define %tc7-vector 13) +(define %tc7-string 21) +(define %tc7-number 23) +(define %tc7-hashtable 29) +(define %tc7-pointer 31) +(define %tc7-fluid 37) +(define %tc7-stringbuf 39) +(define %tc7-dynamic-state 45) +(define %tc7-frame 47) +(define %tc7-objcode 53) +(define %tc7-vm 55) +(define %tc7-vm-continuation 71) +(define %tc7-bytevector 77) +(define %tc7-program 79) +(define %tc7-port 125) +(define %tc7-smob 127) + +(define %tc16-bignum (+ %tc7-number (* 1 256))) +(define %tc16-real (+ %tc7-number (* 2 256))) +(define %tc16-complex (+ %tc7-number (* 3 256))) +(define %tc16-fraction (+ %tc7-number (* 4 256))) + + +;; "Stringbufs". +(define-record-type + (stringbuf string) + stringbuf? + (string stringbuf-contents)) + +(set-record-type-printer! + (lambda (stringbuf port) + (display "#" port))) + +;; Structs. +(define-record-type + (inferior-struct name fields) + inferior-struct? + (name inferior-struct-name) + (fields inferior-struct-fields set-inferior-struct-fields!)) + +(define print-inferior-struct + (let ((%printed-struct (make-parameter vlist-null))) + (lambda (struct port) + (if (vhash-assq struct (%printed-struct)) + (format port "#-1#") + (begin + (format port "#" (object-address struct))))))) + +(set-record-type-printer! print-inferior-struct) + +;; Fluids. +(define-record-type + (inferior-fluid number value) + inferior-fluid? + (number inferior-fluid-number) + (value inferior-fluid-value)) + +(set-record-type-printer! + (lambda (fluid port) + (match fluid + (($ number) + (format port "#" + number + (object-address fluid)))))) + +;; Object type to represent complex objects from the inferior process that +;; cannot be really converted to usable Scheme objects in the current +;; process. +(define-record-type + (%inferior-object kind sub-kind address) + inferior-object? + (kind inferior-object-kind) + (sub-kind inferior-object-sub-kind) + (address inferior-object-address)) + +(define inferior-object + (case-lambda + "Return an object representing an inferior object at ADDRESS, of type +KIND/SUB-KIND." + ((kind address) + (%inferior-object kind #f address)) + ((kind sub-kind address) + (%inferior-object kind sub-kind address)))) + +(set-record-type-printer! + (lambda (io port) + (match io + (($ kind sub-kind address) + (format port "#<~a ~:[~*~;~a ~]~x>" + kind sub-kind sub-kind + address))))) + +(define (inferior-smob backend type-number address) + "Return an object representing the SMOB at ADDRESS whose type is +TYPE-NUMBER." + (inferior-object 'smob + (or (type-number->name backend 'smob type-number) + type-number) + address)) + +(define (inferior-port backend type-number address) + "Return an object representing the port at ADDRESS whose type is +TYPE-NUMBER." + (inferior-object 'port + (or (type-number->name backend 'port type-number) + type-number) + address)) + +(define %visited-cells + ;; Vhash of mapping addresses of already visited cells to the + ;; corresponding inferior object. This is used to detect and represent + ;; cycles. + (make-parameter vlist-null)) + +(define-syntax visited + (syntax-rules (->) + ((_ (address -> object) body ...) + (parameterize ((%visited-cells (vhash-consv address object + (%visited-cells)))) + body ...)))) + +(define (address->inferior-struct address vtable-data-address backend) + "Read the struct at ADDRESS using BACKEND. Return an 'inferior-struct' +object representing it." + (define %vtable-layout-index 0) + (define %vtable-name-index 5) + + (let* ((layout-address (+ vtable-data-address + (* %vtable-layout-index %word-size))) + (layout-bits (dereference-word backend layout-address)) + (layout (scm->object layout-bits backend)) + (name-address (+ vtable-data-address + (* %vtable-name-index %word-size))) + (name-bits (dereference-word backend name-address)) + (name (scm->object name-bits backend))) + (if (symbol? layout) + (let* ((layout (symbol->string layout)) + (len (/ (string-length layout) 2)) + (slots (dereference-word backend (+ address %word-size))) + (port (memory-port backend slots (* len %word-size))) + (fields (get-bytevector-n port (* len %word-size))) + (result (inferior-struct name #f))) + + ;; Keep track of RESULT so callees can refer to it if we are + ;; decoding a circular struct. + (visited (address -> result) + (let ((values (map (cut scm->object <> backend) + (bytevector->uint-list fields + (native-endianness) + %word-size)))) + (set-inferior-struct-fields! result values) + result))) + (inferior-object 'invalid-struct address)))) + +(define* (cell->object address #:optional (backend %ffi-memory-backend)) + "Return an object representing the object at ADDRESS, reading from memory +using BACKEND." + (or (and=> (vhash-assv address (%visited-cells)) cdr) ; circular object + (let ((port (memory-port backend address))) + (match-cell port + (((vtable-data-address & 7 = %tc3-struct)) + (address->inferior-struct address + (- vtable-data-address %tc3-struct) + backend)) + (((_ & #x7f = %tc7-symbol) buf hash props) + (match (cell->object buf backend) + (($ string) + (string->symbol string)))) + (((_ & #x7f = %tc7-string) buf start len) + (match (cell->object buf backend) + (($ string) + (substring string start (+ start len))))) + (((_ & #x047f = %tc7-stringbuf) len (bytevector buf len)) + (stringbuf (bytevector->string buf "ISO-8859-1"))) + (((_ & #x047f = (bitwise-ior #x400 %tc7-stringbuf)) + len (bytevector buf (* 4 len))) + (stringbuf (bytevector->string buf "UTF-32LE"))) + (((_ & #x7f = %tc7-bytevector) len address) + (let ((bv-port (memory-port backend address len))) + (get-bytevector-all bv-port))) + ((((len << 7) || %tc7-vector) weakv-data) + (let* ((len (arithmetic-shift len -1)) + (words (get-bytevector-n port (* len %word-size))) + (vector (make-vector len))) + (visited (address -> vector) + (fold (lambda (element index) + (vector-set! vector index element) + (+ 1 index)) + 0 + (map (cut scm->object <> backend) + (bytevector->uint-list words (native-endianness) + %word-size))) + vector))) + ((((n << 8) || %tc7-fluid) init-value) + (inferior-fluid n #f)) ; TODO: show current value + (((_ & #x7f = %tc7-dynamic-state)) + (inferior-object 'dynamic-state address)) + ((((flags+type << 8) || %tc7-port)) + (inferior-port backend (logand flags+type #xff) address)) + (((_ & #x7f = %tc7-program)) + (inferior-object 'program address)) + (((_ & #xffff = %tc16-bignum)) + (inferior-object 'bignum address)) + (((_ & #xffff = %tc16-real) pad) + (let* ((address (+ address (* 2 %word-size))) + (port (memory-port backend address (sizeof double))) + (words (get-bytevector-n port (sizeof double)))) + (bytevector-ieee-double-ref words 0 (native-endianness)))) + (((_ & #x7f = %tc7-number) mpi) + (inferior-object 'number address)) + (((_ & #x7f = %tc7-hashtable) buckets meta-data unused) + (inferior-object 'hash-table address)) + (((_ & #x7f = %tc7-pointer) address) + (make-pointer address)) + (((_ & #x7f = %tc7-objcode)) + (inferior-object 'objcode address)) + (((_ & #x7f = %tc7-vm)) + (inferior-object 'vm address)) + (((_ & #x7f = %tc7-vm-continuation)) + (inferior-object 'vm-continuation address)) + ((((smob-type << 8) || %tc7-smob) word1) + (inferior-smob backend smob-type address)))))) + + +(define* (scm->object bits #:optional (backend %ffi-memory-backend)) + "Return the Scheme object corresponding to BITS, the bits of an 'SCM' +object." + (match-scm bits + (((integer << 2) || %tc2-int) + integer) + ((address & 6 = %tc3-cons) + (let* ((type (dereference-word backend address)) + (pair? (not (bit-set? 0 type)))) + (if pair? + (or (and=> (vhash-assv address (%visited-cells)) cdr) + (let ((car type) + (cdrloc (+ address %word-size)) + (pair (cons *unspecified* *unspecified*))) + (visited (address -> pair) + (set-car! pair (scm->object car backend)) + (set-cdr! pair + (scm->object (dereference-word backend cdrloc) + backend)) + pair))) + (cell->object address backend)))) + (((char << 8) || %tc8-char) + (integer->char char)) + (((flag << 8) || %tc8-flag) + (case flag + ((0) #f) + ((1) #nil) + ((3) '()) + ((4) #t) + ((8) (if #f #f)) + ((9) (inferior-object 'undefined bits)) + ((10) (eof-object)) + ((11) (inferior-object 'unbound bits)))))) + +;;; Local Variables: +;;; eval: (put 'match-scm 'scheme-indent-function 1) +;;; eval: (put 'match-cell 'scheme-indent-function 1) +;;; eval: (put 'visited 'scheme-indent-function 1) +;;; End: + +;;; types.scm ends here diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 7578bf5e9..41feb1570 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -163,6 +163,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/threads.test \ tests/time.test \ tests/tree-il.test \ + tests/types.test \ tests/version.test \ tests/vlist.test \ tests/weaks.test \ diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test new file mode 100644 index 000000000..e05ab11d7 --- /dev/null +++ b/test-suite/tests/types.test @@ -0,0 +1,154 @@ +;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8; -*- +;;;; +;;;; Copyright (C) 2014 Free Software Foundation, Inc. +;;;; +;;;; This file is part of GNU Guile. +;;;; +;;;; GNU Guile 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 the License, or (at +;;;; your option) any later version. +;;;; +;;;; GNU Guile 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 Lesser +;;;; General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public License +;;;; along with this program. If not, see . + +(define-module (test-types) + #:use-module (test-suite lib) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (system foreign) + #:use-module (system vm vm) + #:use-module (system base types)) + +(define-syntax test-cloneable + (syntax-rules () + "Test whether each simple OBJECT is properly decoded." + ((_ object rest ...) + (begin + (let ((obj object)) + (pass-if-equal (object->string obj) obj + (scm->object (object-address obj)))) + (test-cloneable rest ...))) + ((_) + *unspecified*))) + +;; Test objects that can be directly cloned. +(with-test-prefix "clonable objects" + (test-cloneable + #t #f #nil (if #f #f) (eof-object) + 42 (expt 2 28) 3.14 + "narrow string" "wide στρινγ" + 'symbol 'λ + ;; NB: keywords are SMOBs. + '(2 . 3) (iota 123) '(1 (two ("three"))) + #(1 2 3) #(foo bar baz) + #vu8(255 254 253) + (make-pointer 123) (make-pointer #xdeadbeef))) + +;; Circular objects cannot be compared with 'equal?', so here's their +;; home. +(with-test-prefix "clonable circular objects" + + (pass-if "list" + (let* ((lst (circular-list 0 1)) + (result (scm->object (object-address lst)))) + (match result + ((0 1 . self) + (eq? self result))))) + + (pass-if "vector" + (define (circular-vector) + (let ((v (make-vector 3 'hey))) + (vector-set! v 2 v) + v)) + + (let* ((vec (circular-vector)) + (result (scm->object (object-address vec)))) + (match result + (#('hey 'hey self) + (eq? self result)))))) + +(define-syntax test-inferior-objects + (syntax-rules () + "Test whether each OBJECT is recognized and wrapped as an +'inferior-object'." + ((_ (object kind sub-kind-pattern) rest ...) + (begin + (let ((obj object)) + (pass-if (object->string obj) + (let ((result (scm->object (object-address obj)))) + (and (inferior-object? result) + (eq? 'kind (inferior-object-kind result)) + (match (inferior-object-sub-kind result) + (sub-kind-pattern #t) + (_ #f)))))) + (test-inferior-objects rest ...))) + ((_) + *unspecified*))) + +(with-test-prefix "opaque objects" + (test-inferior-objects + ((make-guardian) smob (? integer?)) + (#:keyword smob (? integer?)) + ((%make-void-port "w") port (? integer?)) + ((open-input-string "hello") port (? integer?)) + ((lambda () #t) program _) + ((the-vm) vm _) + ((expt 2 70) bignum _)) + + (pass-if "fluid" + (let ((fluid (make-fluid))) + (inferior-fluid? (scm->object (object-address fluid)))))) + +(define-record-type + (some-struct x y z) + some-struct? + (x struct-x set-struct-x!) + (y struct-y) + (z struct-z)) + +(with-test-prefix "structs" + + (pass-if-equal "simple struct" + '( a b c) + (let* ((struct (some-struct 'a 'b 'c)) + (result (scm->object (object-address struct)))) + (and (inferior-struct? result) + (cons (inferior-struct-name result) + (inferior-struct-fields result))))) + + (pass-if "circular struct" + (let ((struct (some-struct #f 'b 'c))) + (set-struct-x! struct struct) + (let ((result (scm->object (object-address struct)))) + (and (inferior-struct? result) + (eq? (inferior-struct-name result) ') + (match (inferior-struct-fields result) + ((self 'b 'c) + (eq? self result))))))) + + (pass-if "printed circular struct" + (->bool + (string-match "# #0# b c [[:xdigit:]]+>" + (let ((struct (some-struct #f 'b 'c))) + (set-struct-x! struct struct) + (object->string (scm->object (object-address struct))))))) + + (pass-if "printed deep circular struct" + (->bool + (string-match + "# \ +# #-1# 3 4 [[:xdigit:]]+> \ +1 2 [[:xdigit:]]+>" + (let* ((a (some-struct #f 1 2)) + (b (some-struct a 3 4))) + (set-struct-x! a b) + (object->string (scm->object (object-address a)))))))) -- cgit v1.2.3 From 359f46a41cd703fcec187459eb11aacf1b05d76a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Feb 2014 15:40:34 +0100 Subject: Add GDB extension to support Guile. * libguile/libguile-2.0-gdb.scm: New file. * libguile/Makefile.am (install-data-local): New target. Based on code from GNU libstdc++. (EXTRA_DIST): Add 'libguile-2.0-gdb.scm'. * doc/ref/api-debug.texi (GDB Support): New section. --- doc/ref/api-debug.texi | 42 ++++++++++- libguile/Makefile.am | 40 +++++++++-- libguile/libguile-2.0-gdb.scm | 164 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 237 insertions(+), 9 deletions(-) create mode 100644 libguile/libguile-2.0-gdb.scm diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index f6c706c78..619629b56 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2010, 2011, 2012, 2013 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2010, 2011, 2012, 2013, 2014 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -17,8 +17,9 @@ infrastructure that builds on top of those calls. @menu * Evaluation Model:: Evaluation and the Scheme stack. * Source Properties:: From expressions to source locations. -* Programmatic Error Handling:: Debugging when an error occurs. +* Programmatic Error Handling:: Debugging when an error occurs. * Traps:: Breakpoints, tracepoints, oh my! +* GDB Support:: C-level debugging with GDB. @end menu @node Evaluation Model @@ -1351,6 +1352,43 @@ This is a stepping trap, used to implement the ``step'', ``next'', ``step-instruction'', and ``next-instruction'' REPL commands. @end deffn +@node GDB Support +@subsection GDB Support + +@cindex GDB support + +Sometimes, you may find it necessary to debug Guile applications at the +C level. Doing so can be tedious, in particular because the debugger is +oblivious to Guile's @code{SCM} type, and thus unable to display +@code{SCM} values in any meaningful way: + +@example +(gdb) frame +#0 scm_display (obj=0xf04310, port=0x6f9f30) at print.c:1437 +@end example + +To address that, Guile comes with an extension of the GNU Debugger (GDB) +that contains a ``pretty-printer'' for @code{SCM} values. With this GDB +extension, the C frame in the example above shows up like this: + +@example +(gdb) frame +#0 scm_display (obj=("hello" GDB!), port=#) at print.c:1437 +@end example + +@noindent +Here GDB was able to decode the list pointed to by @var{obj}, and to +print it using Scheme's read syntax. + +That extension is a @code{.scm} file installed alongside the +@file{libguile} shared library. When GDB 7.8 or later is installed and +compiled with support for extensions written in Guile, the extension is +automatically loaded when debugging a program linked against +@file{libguile} (@pxref{Auto-loading,,, gdb, Debugging with GDB}). Note +that the directory where @file{libguile} is installed must be among +GDB's auto-loading ``safe directories'' (@pxref{Auto-loading safe +path,,, gdb, Debugging with GDB}). + @c Local Variables: @c TeX-master: "guile.texi" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index dcbdba12a..c7ceb16c1 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -1,7 +1,7 @@ ## Process this file with Automake to create Makefile.in ## ## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, -## 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +## 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -448,6 +448,31 @@ EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = _scm.h \ install-exec-hook: rm -f $(DESTDIR)$(bindir)/guile-snarf.awk +install-data-local: libguile-2.0-gdb.scm + @$(MKDIR_P) $(DESTDIR)$(libdir) +## We want to install libguile-2.0-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) libguile-2.0-gdb.scm \ +$(DESTDIR)$(libdir)/$$libname-gdb.scm"; \ + $(INSTALL_DATA) libguile-2.0-gdb.scm \ + $(DESTDIR)$(libdir)/$$libname-gdb.scm + ## 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 @@ -635,12 +660,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.0-gdb.scm # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi diff --git a/libguile/libguile-2.0-gdb.scm b/libguile/libguile-2.0-gdb.scm new file mode 100644 index 000000000..fdd5cd81b --- /dev/null +++ b/libguile/libguile-2.0-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 . + +(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.0-gdb.scm ends here -- cgit v1.2.3 From 8f5dbecb4bfe9862d3603b2848cd115d5a164a4f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Feb 2014 22:56:17 +0100 Subject: build: Bail out when 'PKG_CHECK_MODULES' is missing. * configure.ac: Add 'm4_pattern_forbid' invocation. --- configure.ac | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index d0d9851c1..e99b27290 100644 --- a/configure.ac +++ b/configure.ac @@ -5,7 +5,7 @@ dnl define(GUILE_CONFIGURE_COPYRIGHT,[[ Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, - 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. + 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. This file is part of GUILE @@ -51,6 +51,10 @@ GUILE_VERSION="$PACKAGE_VERSION" AC_CONFIG_HEADERS([config.h]) AH_TOP(/*GUILE_CONFIGURE_COPYRIGHT*/) +dnl We require the pkg.m4 set of macros from pkg-config. +dnl Make sure it's available. +m4_pattern_forbid([PKG_CHECK_MODULES]) + #-------------------------------------------------------------------- AC_LANG([C]) -- cgit v1.2.3 From ae8d8a84ef0187a3d732e43c459182ed15536dc1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Feb 2014 22:57:26 +0100 Subject: Make sure 'ftw' allows directory traversal when running as root. * module/ice-9/ftw.scm (stat-dir-readable?-proc): Return #t when UID is zero. Reported Frank Terbeck . --- module/ice-9/ftw.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm index 9c9694fd7..133e9c9b5 100644 --- a/module/ice-9/ftw.scm +++ b/module/ice-9/ftw.scm @@ -1,6 +1,6 @@ ;;;; ftw.scm --- file system tree walk -;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012, 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 @@ -259,7 +259,8 @@ (let* ((perms (stat:perms s)) (perms-bit-set? (lambda (mask) (not (= 0 (logand mask perms)))))) - (or (and (= uid (stat:uid s)) + (or (zero? uid) + (and (= uid (stat:uid s)) (perms-bit-set? #o400)) (and (= gid (stat:gid s)) (perms-bit-set? #o040)) -- cgit v1.2.3 From a8b80d6b29b33ea39c96e5e366a0365886b31dc8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 27 Feb 2014 14:14:21 +0100 Subject: build: Fix out-of-source-tree installation of libguile-2.0-gdb.scm. * libguile/Makefile.am (install-data-local): Use $< instead of just libguile-2.0-gdb.scm. Quote file names in $(INSTALL_DATA) invocation. --- libguile/Makefile.am | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index c7ceb16c1..6a631d89f 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -468,10 +468,10 @@ install-data-local: libguile-2.0-gdb.scm esac; \ done; \ cd $$here; \ - echo " $(INSTALL_DATA) libguile-2.0-gdb.scm \ + echo " $(INSTALL_DATA) $< \ $(DESTDIR)$(libdir)/$$libname-gdb.scm"; \ - $(INSTALL_DATA) libguile-2.0-gdb.scm \ - $(DESTDIR)$(libdir)/$$libname-gdb.scm + $(INSTALL_DATA) "$<" \ + "$(DESTDIR)$(libdir)/$$libname-gdb.scm" ## 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. -- cgit v1.2.3 From caa3d99be9932077230303a5571697f7d45f3da2 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 25 Feb 2014 17:38:34 -0500 Subject: Fix typo in manual. * doc/ref/api-foreign.texi (Void Pointers and Byte Access): (rnrs bytevector) --> (rnrs bytevectors). --- doc/ref/api-foreign.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index 381c10d63..c2c49ec48 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -604,7 +604,7 @@ Unpack the pointer value from a pointer object. Wrapped pointers are untyped, so they are essentially equivalent to C @code{void} pointers. As in C, the memory region pointed to by a pointer can be accessed at the byte level. This is achieved using -@emph{bytevectors} (@pxref{Bytevectors}). The @code{(rnrs bytevector)} +@emph{bytevectors} (@pxref{Bytevectors}). The @code{(rnrs bytevectors)} module contains procedures that can be used to convert byte sequences to Scheme objects such as strings, floating point numbers, or integers. -- cgit v1.2.3 From 3243fffcc19144fc0b30e983c3e50d1d1fc19ef4 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 26 Feb 2014 22:15:13 -0500 Subject: Import Gnulib modules: link, fsync, readlink, rename, mkdir, rmdir, unistd. * lib/fsync.c: * lib/link.c: * lib/mkdir.c: * lib/strdup.c: * m4/fsync.m4: * m4/link.m4: * m4/mkdir.m4: * m4/strdup.m4: New files. * lib/Makefile.am * m4/gnulib-cache.m4 * m4/gnulib-comp.m4: Add modules. --- lib/Makefile.am | 38 +++++++++- lib/fsync.c | 83 +++++++++++++++++++++ lib/link.c | 211 +++++++++++++++++++++++++++++++++++++++++++++++++++++ lib/mkdir.c | 93 +++++++++++++++++++++++ lib/strdup.c | 54 ++++++++++++++ m4/fsync.m4 | 17 +++++ m4/gnulib-cache.m4 | 8 +- m4/gnulib-comp.m4 | 33 +++++++++ m4/link.m4 | 55 ++++++++++++++ m4/mkdir.m4 | 69 ++++++++++++++++++ m4/strdup.m4 | 36 +++++++++ 11 files changed, 695 insertions(+), 2 deletions(-) create mode 100644 lib/fsync.c create mode 100644 lib/link.c create mode 100644 lib/mkdir.c create mode 100644 lib/strdup.c create mode 100644 m4/fsync.m4 create mode 100644 m4/link.m4 create mode 100644 m4/mkdir.m4 create mode 100644 m4/strdup.m4 diff --git a/lib/Makefile.am b/lib/Makefile.am index 18cb5e3bb..8b643c72b 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar AUTOMAKE_OPTIONS = 1.9.6 gnits subdir-objects @@ -567,6 +567,15 @@ EXTRA_libgnu_la_SOURCES += fstat.c ## end gnulib module fstat +## begin gnulib module fsync + + +EXTRA_DIST += fsync.c + +EXTRA_libgnu_la_SOURCES += fsync.c + +## end gnulib module fsync + ## begin gnulib module full-read libgnu_la_SOURCES += full-read.h full-read.c @@ -905,6 +914,15 @@ EXTRA_DIST += libunistring.valgrind ## end gnulib module libunistring +## begin gnulib module link + + +EXTRA_DIST += link.c + +EXTRA_libgnu_la_SOURCES += link.c + +## end gnulib module link + ## begin gnulib module listen @@ -1417,6 +1435,15 @@ EXTRA_libgnu_la_SOURCES += memchr.c ## end gnulib module memchr +## begin gnulib module mkdir + + +EXTRA_DIST += mkdir.c + +EXTRA_libgnu_la_SOURCES += mkdir.c + +## end gnulib module mkdir + ## begin gnulib module mkstemp @@ -2336,6 +2363,15 @@ EXTRA_DIST += stdlib.in.h ## end gnulib module stdlib +## begin gnulib module strdup-posix + + +EXTRA_DIST += strdup.c + +EXTRA_libgnu_la_SOURCES += strdup.c + +## end gnulib module strdup-posix + ## begin gnulib module streq diff --git a/lib/fsync.c b/lib/fsync.c new file mode 100644 index 000000000..99475ff65 --- /dev/null +++ b/lib/fsync.c @@ -0,0 +1,83 @@ +/* Emulate fsync on platforms that lack it, primarily Windows and + cross-compilers like MinGW. + + This is derived from sqlite3 sources. + http://www.sqlite.org/cvstrac/rlog?f=sqlite/src/os_win.c + http://www.sqlite.org/copyright.html + + Written by Richard W.M. Jones + + Copyright (C) 2008-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 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include +#include + +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + +/* FlushFileBuffers */ +# define WIN32_LEAN_AND_MEAN +# include + +# include + +/* Get _get_osfhandle. */ +# include "msvc-nothrow.h" + +int +fsync (int fd) +{ + HANDLE h = (HANDLE) _get_osfhandle (fd); + DWORD err; + + if (h == INVALID_HANDLE_VALUE) + { + errno = EBADF; + return -1; + } + + if (!FlushFileBuffers (h)) + { + /* Translate some Windows errors into rough approximations of Unix + * errors. MSDN is useless as usual - in this case it doesn't + * document the full range of errors. + */ + err = GetLastError (); + switch (err) + { + case ERROR_ACCESS_DENIED: + /* For a read-only handle, fsync should succeed, even though we have + no way to sync the access-time changes. */ + return 0; + + /* eg. Trying to fsync a tty. */ + case ERROR_INVALID_HANDLE: + errno = EINVAL; + break; + + default: + errno = EIO; + } + return -1; + } + + return 0; +} + +#else /* !Windows */ + +# error "This platform lacks fsync function, and Gnulib doesn't provide a replacement. This is a bug in Gnulib." + +#endif /* !Windows */ diff --git a/lib/link.c b/lib/link.c new file mode 100644 index 000000000..9db1f8cef --- /dev/null +++ b/lib/link.c @@ -0,0 +1,211 @@ +/* Emulate link on platforms that lack it, namely native Windows platforms. + + Copyright (C) 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 published by + the Free Software Foundation; either version 2, 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, see . */ + +#include + +#include + +#include +#include +#include +#include + +#if !HAVE_LINK +# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + +# define WIN32_LEAN_AND_MEAN +# include + +/* CreateHardLink was introduced only in Windows 2000. */ +typedef BOOL (WINAPI * CreateHardLinkFuncType) (LPCTSTR lpFileName, + LPCTSTR lpExistingFileName, + LPSECURITY_ATTRIBUTES lpSecurityAttributes); +static CreateHardLinkFuncType CreateHardLinkFunc = NULL; +static BOOL initialized = FALSE; + +static void +initialize (void) +{ + HMODULE kernel32 = GetModuleHandle ("kernel32.dll"); + if (kernel32 != NULL) + { + CreateHardLinkFunc = + (CreateHardLinkFuncType) GetProcAddress (kernel32, "CreateHardLinkA"); + } + initialized = TRUE; +} + +int +link (const char *file1, const char *file2) +{ + char *dir; + size_t len1 = strlen (file1); + size_t len2 = strlen (file2); + if (!initialized) + initialize (); + if (CreateHardLinkFunc == NULL) + { + /* System does not support hard links. */ + errno = EPERM; + return -1; + } + /* Reject trailing slashes on non-directories; mingw does not + support hard-linking directories. */ + if ((len1 && (file1[len1 - 1] == '/' || file1[len1 - 1] == '\\')) + || (len2 && (file2[len2 - 1] == '/' || file2[len2 - 1] == '\\'))) + { + struct stat st; + if (stat (file1, &st) == 0 && S_ISDIR (st.st_mode)) + errno = EPERM; + else + errno = ENOTDIR; + return -1; + } + /* CreateHardLink("b/.","a",NULL) creates file "b", so we must check + that dirname(file2) exists. */ + dir = strdup (file2); + if (!dir) + return -1; + { + struct stat st; + char *p = strchr (dir, '\0'); + while (dir < p && (*--p != '/' && *p != '\\')); + *p = '\0'; + if (p != dir && stat (dir, &st) == -1) + { + int saved_errno = errno; + free (dir); + errno = saved_errno; + return -1; + } + free (dir); + } + /* Now create the link. */ + if (CreateHardLinkFunc (file2, file1, NULL) == 0) + { + /* It is not documented which errors CreateHardLink() can produce. + * The following conversions are based on tests on a Windows XP SP2 + * system. */ + DWORD err = GetLastError (); + switch (err) + { + case ERROR_ACCESS_DENIED: + errno = EACCES; + break; + + case ERROR_INVALID_FUNCTION: /* fs does not support hard links */ + errno = EPERM; + break; + + case ERROR_NOT_SAME_DEVICE: + errno = EXDEV; + break; + + case ERROR_PATH_NOT_FOUND: + case ERROR_FILE_NOT_FOUND: + errno = ENOENT; + break; + + case ERROR_INVALID_PARAMETER: + errno = ENAMETOOLONG; + break; + + case ERROR_TOO_MANY_LINKS: + errno = EMLINK; + break; + + case ERROR_ALREADY_EXISTS: + errno = EEXIST; + break; + + default: + errno = EIO; + } + return -1; + } + + return 0; +} + +# else /* !Windows */ + +# error "This platform lacks a link function, and Gnulib doesn't provide a replacement. This is a bug in Gnulib." + +# endif /* !Windows */ +#else /* HAVE_LINK */ + +# undef link + +/* Create a hard link from FILE1 to FILE2, working around platform bugs. */ +int +rpl_link (char const *file1, char const *file2) +{ + size_t len1; + size_t len2; + struct stat st; + + /* Don't allow IRIX to dereference dangling file2 symlink. */ + if (!lstat (file2, &st)) + { + errno = EEXIST; + return -1; + } + + /* Reject trailing slashes on non-directories. */ + len1 = strlen (file1); + len2 = strlen (file2); + if ((len1 && file1[len1 - 1] == '/') + || (len2 && file2[len2 - 1] == '/')) + { + /* Let link() decide whether hard-linking directories is legal. + If stat() fails, then link() should fail for the same reason + (although on Solaris 9, link("file/","oops") mistakenly + succeeds); if stat() succeeds, require a directory. */ + if (stat (file1, &st)) + return -1; + if (!S_ISDIR (st.st_mode)) + { + errno = ENOTDIR; + return -1; + } + } + else + { + /* Fix Cygwin 1.5.x bug where link("a","b/.") creates file "b". */ + char *dir = strdup (file2); + char *p; + if (!dir) + return -1; + /* We already know file2 does not end in slash. Strip off the + basename, then check that the dirname exists. */ + p = strrchr (dir, '/'); + if (p) + { + *p = '\0'; + if (stat (dir, &st) == -1) + { + int saved_errno = errno; + free (dir); + errno = saved_errno; + return -1; + } + } + free (dir); + } + return link (file1, file2); +} +#endif /* HAVE_LINK */ diff --git a/lib/mkdir.c b/lib/mkdir.c new file mode 100644 index 000000000..f1b802b57 --- /dev/null +++ b/lib/mkdir.c @@ -0,0 +1,93 @@ +/* On some systems, mkdir ("foo/", 0700) fails because of the trailing + slash. On those systems, this wrapper removes the trailing slash. + + Copyright (C) 2001, 2003, 2006, 2008-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 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +/* written by Jim Meyering */ + +#include + +/* Specification. */ +#include + +#include +#include +#include +#include + +#include "dirname.h" + +/* Disable the definition of mkdir to rpl_mkdir (from the + substitute) in this file. Otherwise, we'd get an endless recursion. */ +#undef mkdir + +/* mingw's _mkdir() function has 1 argument, but we pass 2 arguments. + Additionally, it declares _mkdir (and depending on compile flags, an + alias mkdir), only in the nonstandard includes and , + which are included in the override. */ +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ +# define mkdir(name,mode) _mkdir (name) +# define maybe_unused _GL_UNUSED +#else +# define maybe_unused /* empty */ +#endif + +/* This function is required at least for NetBSD 1.5.2. */ + +int +rpl_mkdir (char const *dir, mode_t mode maybe_unused) +{ + int ret_val; + char *tmp_dir; + size_t len = strlen (dir); + + if (len && dir[len - 1] == '/') + { + tmp_dir = strdup (dir); + if (!tmp_dir) + { + /* Rather than rely on strdup-posix, we set errno ourselves. */ + errno = ENOMEM; + return -1; + } + strip_trailing_slashes (tmp_dir); + } + else + { + tmp_dir = (char *) dir; + } +#if FUNC_MKDIR_DOT_BUG + /* Additionally, cygwin 1.5 mistakenly creates a directory "d/./". */ + { + char *last = last_component (tmp_dir); + if (*last == '.' && (last[1] == '\0' + || (last[1] == '.' && last[2] == '\0'))) + { + struct stat st; + if (stat (tmp_dir, &st) == 0) + errno = EEXIST; + return -1; + } + } +#endif /* FUNC_MKDIR_DOT_BUG */ + + ret_val = mkdir (tmp_dir, mode); + + if (tmp_dir != dir) + free (tmp_dir); + + return ret_val; +} diff --git a/lib/strdup.c b/lib/strdup.c new file mode 100644 index 000000000..bde582927 --- /dev/null +++ b/lib/strdup.c @@ -0,0 +1,54 @@ +/* Copyright (C) 1991, 1996-1998, 2002-2004, 2006-2007, 2009-2014 Free Software + Foundation, Inc. + + This file is part of the GNU C Library. + + This program 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 2, 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, see . */ + +#ifndef _LIBC +# include +#endif + +/* Get specification. */ +#include + +#include + +#undef __strdup +#ifdef _LIBC +# undef strdup +#endif + +#ifndef weak_alias +# define __strdup strdup +#endif + +/* Duplicate S, returning an identical malloc'd string. */ +char * +__strdup (const char *s) +{ + size_t len = strlen (s) + 1; + void *new = malloc (len); + + if (new == NULL) + return NULL; + + return (char *) memcpy (new, s, len); +} +#ifdef libc_hidden_def +libc_hidden_def (__strdup) +#endif +#ifdef weak_alias +weak_alias (__strdup, strdup) +#endif diff --git a/m4/fsync.m4 b/m4/fsync.m4 new file mode 100644 index 000000000..888a65def --- /dev/null +++ b/m4/fsync.m4 @@ -0,0 +1,17 @@ +# fsync.m4 serial 2 +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FUNC_FSYNC], +[ + AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) + AC_CHECK_FUNCS_ONCE([fsync]) + if test $ac_cv_func_fsync = no; then + HAVE_FSYNC=0 + fi +]) + +# Prerequisites of lib/fsync.c. +AC_DEFUN([gl_PREREQ_FSYNC], [:]) diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 3c3c65d85..fc7391cda 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -27,7 +27,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc verify vsnprintf warnings wchar +# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) @@ -55,6 +55,7 @@ gl_MODULES([ fpieee frexp fstat + fsync full-read full-write func @@ -79,6 +80,7 @@ gl_MODULES([ lib-symbol-versions lib-symbol-visibility libunistring + link listen localcharset locale @@ -87,6 +89,7 @@ gl_MODULES([ maintainer-makefile malloc-gnu malloca + mkdir mkstemp nl_langinfo nproc @@ -95,10 +98,12 @@ gl_MODULES([ pipe2 poll putenv + readlink recv recvfrom regex rename + rmdir select send sendto @@ -115,6 +120,7 @@ gl_MODULES([ time times trunc + unistd verify vsnprintf warnings diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 74a51f79e..b333d6aed 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -84,6 +84,7 @@ AC_DEFUN([gl_EARLY], AC_REQUIRE([gl_FP_IEEE]) # Code from module frexp: # Code from module fstat: + # Code from module fsync: # Code from module full-read: # Code from module full-write: # Code from module func: @@ -127,6 +128,7 @@ AC_DEFUN([gl_EARLY], # Code from module lib-symbol-versions: # Code from module lib-symbol-visibility: # Code from module libunistring: + # Code from module link: # Code from module listen: # Code from module localcharset: # Code from module locale: @@ -144,6 +146,7 @@ AC_DEFUN([gl_EARLY], # Code from module mbsinit: # Code from module mbtowc: # Code from module memchr: + # Code from module mkdir: # Code from module mkstemp: # Code from module msvc-inval: # Code from module msvc-nothrow: @@ -202,6 +205,7 @@ AC_DEFUN([gl_EARLY], # Code from module stdint: # Code from module stdio: # Code from module stdlib: + # Code from module strdup-posix: # Code from module streq: # Code from module strftime: # Code from module striconveh: @@ -365,6 +369,12 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_FSTAT fi gl_SYS_STAT_MODULE_INDICATOR([fstat]) + gl_FUNC_FSYNC + if test $HAVE_FSYNC = 0; then + AC_LIBOBJ([fsync]) + gl_PREREQ_FSYNC + fi + gl_UNISTD_MODULE_INDICATOR([fsync]) gl_FUNC gl_GETADDRINFO if test $HAVE_GETADDRINFO = 0; then @@ -499,6 +509,11 @@ AC_SUBST([LTALLOCA]) gl_LD_VERSION_SCRIPT gl_VISIBILITY gl_LIBUNISTRING + gl_FUNC_LINK + if test $HAVE_LINK = 0 || test $REPLACE_LINK = 1; then + AC_LIBOBJ([link]) + fi + gl_UNISTD_MODULE_INDICATOR([link]) AC_REQUIRE([gl_HEADER_SYS_SOCKET]) if test "$ac_cv_header_winsock2_h" = yes; then AC_LIBOBJ([listen]) @@ -570,6 +585,10 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_MEMCHR fi gl_STRING_MODULE_INDICATOR([memchr]) + gl_FUNC_MKDIR + if test $REPLACE_MKDIR = 1; then + AC_LIBOBJ([mkdir]) + fi gl_FUNC_MKSTEMP if test $HAVE_MKSTEMP = 0 || test $REPLACE_MKSTEMP = 1; then AC_LIBOBJ([mkstemp]) @@ -752,6 +771,12 @@ AC_SUBST([LTALLOCA]) gl_STDINT_H gl_STDIO_H gl_STDLIB_H + gl_FUNC_STRDUP_POSIX + if test $ac_cv_func_strdup = no || test $REPLACE_STRDUP = 1; then + AC_LIBOBJ([strdup]) + gl_PREREQ_STRDUP + fi + gl_STRING_MODULE_INDICATOR([strdup]) gl_FUNC_GNU_STRFTIME if test $gl_cond_libtool = false; then gl_ltlibdeps="$gl_ltlibdeps $LTLIBICONV" @@ -1016,6 +1041,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/floor.c lib/frexp.c lib/fstat.c + lib/fsync.c lib/full-read.c lib/full-read.h lib/full-write.c @@ -1055,6 +1081,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/itold.c lib/langinfo.in.h lib/libunistring.valgrind + lib/link.c lib/listen.c lib/localcharset.c lib/localcharset.h @@ -1075,6 +1102,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/mbtowc.c lib/memchr.c lib/memchr.valgrind + lib/mkdir.c lib/mkstemp.c lib/msvc-inval.c lib/msvc-inval.h @@ -1142,6 +1170,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/stdint.in.h lib/stdio.in.h lib/stdlib.in.h + lib/strdup.c lib/streq.h lib/strftime.c lib/strftime.h @@ -1225,6 +1254,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/fpieee.m4 m4/frexp.m4 m4/fstat.m4 + m4/fsync.m4 m4/func.m4 m4/getaddrinfo.m4 m4/getlogin.m4 @@ -1257,6 +1287,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/lib-prefix.m4 m4/libunistring-base.m4 m4/libunistring.m4 + m4/link.m4 m4/localcharset.m4 m4/locale-fr.m4 m4/locale-ja.m4 @@ -1277,6 +1308,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/mbstate_t.m4 m4/mbtowc.m4 m4/memchr.m4 + m4/mkdir.m4 m4/mkstemp.m4 m4/mmap-anon.m4 m4/mode_t.m4 @@ -1328,6 +1360,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/stdint_h.m4 m4/stdio_h.m4 m4/stdlib_h.m4 + m4/strdup.m4 m4/strftime.m4 m4/string_h.m4 m4/sys_file_h.m4 diff --git a/m4/link.m4 b/m4/link.m4 new file mode 100644 index 000000000..e923d0d02 --- /dev/null +++ b/m4/link.m4 @@ -0,0 +1,55 @@ +# link.m4 serial 8 +dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FUNC_LINK], +[ + AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CHECK_FUNCS_ONCE([link]) + if test $ac_cv_func_link = no; then + HAVE_LINK=0 + else + AC_CACHE_CHECK([whether link obeys POSIX], + [gl_cv_func_link_works], + [touch conftest.a + # Assume that if we have lstat, we can also check symlinks. + if test $ac_cv_func_lstat = yes; then + ln -s conftest.a conftest.lnk + fi + AC_RUN_IFELSE( + [AC_LANG_PROGRAM( + [[#include + ]], + [[int result = 0; + if (!link ("conftest.a", "conftest.b/")) + result |= 1; +#if HAVE_LSTAT + if (!link ("conftest.lnk/", "conftest.b")) + result |= 2; + if (rename ("conftest.a", "conftest.b")) + result |= 4; + if (!link ("conftest.b", "conftest.lnk")) + result |= 8; +#endif + return result; + ]])], + [gl_cv_func_link_works=yes], [gl_cv_func_link_works=no], + [case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_link_works="guessing yes" ;; + # If we don't know, assume the worst. + *) gl_cv_func_link_works="guessing no" ;; + esac + ]) + rm -f conftest.a conftest.b conftest.lnk]) + case "$gl_cv_func_link_works" in + *yes) ;; + *) + REPLACE_LINK=1 + ;; + esac + fi +]) diff --git a/m4/mkdir.m4 b/m4/mkdir.m4 new file mode 100644 index 000000000..51e78c13d --- /dev/null +++ b/m4/mkdir.m4 @@ -0,0 +1,69 @@ +# serial 11 + +# Copyright (C) 2001, 2003-2004, 2006, 2008-2014 Free Software Foundation, Inc. +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# On some systems, mkdir ("foo/", 0700) fails because of the trailing slash. +# On others, mkdir ("foo/./", 0700) mistakenly succeeds. +# On such systems, arrange to use a wrapper function. +AC_DEFUN([gl_FUNC_MKDIR], +[dnl + AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CHECK_HEADERS_ONCE([unistd.h]) + AC_CACHE_CHECK([whether mkdir handles trailing slash], + [gl_cv_func_mkdir_trailing_slash_works], + [rm -rf conftest.dir + AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +# include +# include +]], [return mkdir ("conftest.dir/", 0700);])], + [gl_cv_func_mkdir_trailing_slash_works=yes], + [gl_cv_func_mkdir_trailing_slash_works=no], + [case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_mkdir_trailing_slash_works="guessing yes" ;; + # If we don't know, assume the worst. + *) gl_cv_func_mkdir_trailing_slash_works="guessing no" ;; + esac + ]) + rm -rf conftest.dir + ] + ) + case "$gl_cv_func_mkdir_trailing_slash_works" in + *yes) ;; + *) + REPLACE_MKDIR=1 + ;; + esac + + AC_CACHE_CHECK([whether mkdir handles trailing dot], + [gl_cv_func_mkdir_trailing_dot_works], + [rm -rf conftest.dir + AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +# include +# include +]], [return !mkdir ("conftest.dir/./", 0700);])], + [gl_cv_func_mkdir_trailing_dot_works=yes], + [gl_cv_func_mkdir_trailing_dot_works=no], + [case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_mkdir_trailing_dot_works="guessing yes" ;; + # If we don't know, assume the worst. + *) gl_cv_func_mkdir_trailing_dot_works="guessing no" ;; + esac + ]) + rm -rf conftest.dir + ] + ) + case "$gl_cv_func_mkdir_trailing_dot_works" in + *yes) ;; + *) + REPLACE_MKDIR=1 + AC_DEFINE([FUNC_MKDIR_DOT_BUG], [1], [Define to 1 if mkdir mistakenly + creates a directory given with a trailing dot component.]) + ;; + esac +]) diff --git a/m4/strdup.m4 b/m4/strdup.m4 new file mode 100644 index 000000000..1681a30eb --- /dev/null +++ b/m4/strdup.m4 @@ -0,0 +1,36 @@ +# strdup.m4 serial 13 + +dnl Copyright (C) 2002-2014 Free Software Foundation, Inc. + +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FUNC_STRDUP], +[ + AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS]) + AC_CHECK_FUNCS_ONCE([strdup]) + AC_CHECK_DECLS_ONCE([strdup]) + if test $ac_cv_have_decl_strdup = no; then + HAVE_DECL_STRDUP=0 + fi +]) + +AC_DEFUN([gl_FUNC_STRDUP_POSIX], +[ + AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS]) + AC_REQUIRE([gl_CHECK_MALLOC_POSIX]) + AC_CHECK_FUNCS_ONCE([strdup]) + if test $ac_cv_func_strdup = yes; then + if test $gl_cv_func_malloc_posix != yes; then + REPLACE_STRDUP=1 + fi + fi + AC_CHECK_DECLS_ONCE([strdup]) + if test $ac_cv_have_decl_strdup = no; then + HAVE_DECL_STRDUP=0 + fi +]) + +# Prerequisites of lib/strdup.c. +AC_DEFUN([gl_PREREQ_STRDUP], [:]) -- cgit v1.2.3 From ca6adcc6df462f325dfa7b099295fd6212d02b43 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 27 Feb 2014 21:24:40 -0500 Subject: Rely on Gnulib for fsync, link, readlink, mkdir, rmdir, and rename. * libguile/filesys.c: Remove 'fsync' wrapper for MinGW. (scm_link, scm_readlink, scm_mkdir, scm_rmdir): Define these unconditionally. (my_rename): Remove. (scm_rename): Use 'rename' instead of 'my_rename'. --- libguile/filesys.c | 38 ++------------------------------------ 1 file changed, 2 insertions(+), 36 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index c261928f5..82ff910cb 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 @@ -110,12 +110,6 @@ #include -/* 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 */ @@ -590,7 +584,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" @@ -609,7 +602,6 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME -#endif /* HAVE_LINK */ /* {Navigating Directories} @@ -1012,7 +1004,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" @@ -1051,7 +1042,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), @@ -1254,7 +1244,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" @@ -1281,9 +1270,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" @@ -1298,27 +1285,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), @@ -1330,7 +1296,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; -- cgit v1.2.3 From bc8e6d7d8ca602c86591466f5e9d816a614700f5 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 27 Feb 2014 22:04:39 -0500 Subject: Rely on Gnulib for . * libguile/async.c: * libguile/backtrace.c: * libguile/error.c: * libguile/filesys.c: * libguile/fports.c: * libguile/gc-malloc.c: * libguile/gc.c: * libguile/gdbint.c: * libguile/init.c: * libguile/ioext.c: * libguile/load.c: * libguile/mallocs.c: * libguile/mkstemp.c: * libguile/ports.c: * libguile/posix.c: * libguile/r6rs-ports.c: * libguile/random.c: * libguile/rw.c: * libguile/scmsigs.c: * libguile/script.c: * libguile/simpos.c: * libguile/socket.c: * libguile/stime.c: * libguile/strports.c: * libguile/threads.c: Unconditionally include . --- libguile/async.c | 5 ++--- libguile/backtrace.c | 5 ++--- libguile/error.c | 4 +--- libguile/filesys.c | 2 -- libguile/fports.c | 2 -- libguile/gc-malloc.c | 5 ++--- libguile/gc.c | 4 +--- libguile/gdbint.c | 6 ++---- libguile/init.c | 5 ++--- libguile/ioext.c | 5 ++--- libguile/load.c | 5 +---- libguile/mallocs.c | 5 ++--- libguile/mkstemp.c | 6 +++--- libguile/ports.c | 5 ++--- libguile/posix.c | 5 ++--- libguile/r6rs-ports.c | 5 +---- libguile/random.c | 6 ++---- libguile/rw.c | 4 +--- libguile/scmsigs.c | 5 ++--- libguile/script.c | 4 +--- libguile/simpos.c | 4 +--- libguile/socket.c | 2 -- libguile/stime.c | 5 ++--- libguile/strports.c | 4 +--- libguile/threads.c | 6 ++---- 25 files changed, 37 insertions(+), 77 deletions(-) diff --git a/libguile/async.c b/libguile/async.c index 66f0b04cd..419bf9b02 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 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, + * 2009, 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 @@ -38,9 +39,7 @@ #ifdef HAVE_STRING_H #include #endif -#ifdef HAVE_UNISTD_H #include -#endif #include diff --git a/libguile/backtrace.c b/libguile/backtrace.c index b0dc0f117..f8283ab4f 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 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 -#endif #ifdef HAVE_IO_H #include #endif diff --git a/libguile/error.c b/libguile/error.c index 26cf5b6d6..b5565a069 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2004, 2006, 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 @@ -40,9 +40,7 @@ #ifdef HAVE_STRING_H #include #endif -#ifdef HAVE_UNISTD_H #include -#endif /* For Windows... */ #ifdef HAVE_IO_H diff --git a/libguile/filesys.c b/libguile/filesys.c index 82ff910cb..09f6cf9a5 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -72,9 +72,7 @@ # endif #endif -#ifdef HAVE_UNISTD_H #include -#endif #ifdef LIBC_H_WITH_UNISTD_H #include diff --git a/libguile/fports.c b/libguile/fports.c index 365d3ffe0..5549bb124 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -33,9 +33,7 @@ #ifdef HAVE_STRING_H #include #endif -#ifdef HAVE_UNISTD_H #include -#endif #ifdef HAVE_IO_H #include #endif diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c index 2aff4c31a..12f52cd0d 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 Free Software Foundation, Inc. + * 2004, 2006, 2008, 2009, 2010, 2011, 2012, + * 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 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/debug-malloc.h" #endif -#ifdef HAVE_UNISTD_H #include -#endif /* INIT_MALLOC_LIMIT is the initial amount of malloc usage which will diff --git a/libguile/gc.c b/libguile/gc.c index 01e1ace80..097cb3dac 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, - * 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. + * 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 @@ -69,9 +69,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/debug-malloc.h" #endif -#ifdef HAVE_UNISTD_H #include -#endif /* Set this to != 0 if every cell that is accessed shall be checked: */ diff --git a/libguile/gdbint.c b/libguile/gdbint.c index 7a0ebc985..0628c98d8 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -1,6 +1,6 @@ /* GDB interface for Guile - * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,2009,2011,2012 - * Free Software Foundation, Inc. + * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,2009,2011,2012, + * 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 @@ -26,9 +26,7 @@ #include #include -#ifdef HAVE_UNISTD_H #include -#endif #include "libguile/strports.h" #include "libguile/read.h" diff --git a/libguile/init.c b/libguile/init.c index 455a772d8..b3203609c 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 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 @@ -146,9 +147,7 @@ #ifdef HAVE_STRING_H #include #endif -#ifdef HAVE_UNISTD_H #include -#endif diff --git a/libguile/ioext.c b/libguile/ioext.c index 089ef1a01..d324cc28d 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2006, + * 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 #endif -#ifdef HAVE_UNISTD_H #include -#endif SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0, diff --git a/libguile/load.c b/libguile/load.c index fbbbae406..50b3180e6 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 @@ -50,10 +50,7 @@ #include #include - -#ifdef HAVE_UNISTD_H #include -#endif /* HAVE_UNISTD_H */ #ifdef HAVE_PWD_H #include diff --git a/libguile/mallocs.c b/libguile/mallocs.c index 05c6a8529..de11972c0 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -1,5 +1,6 @@ /* classes: src_files - * Copyright (C) 1995,1997,1998,2000,2001, 2006 Free Software Foundation, Inc. + * Copyright (C) 1995,1997,1998,2000,2001, 2006, + * 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 -#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 #include #include -#ifdef HAVE_UNISTD_H #include -#endif #ifdef HAVE_SYS_TIME_H #include #endif diff --git a/libguile/ports.c b/libguile/ports.c index 720ffc1b5..be12a8d5e 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 @@ -71,9 +72,7 @@ #include #endif -#ifdef HAVE_UNISTD_H #include -#endif #ifdef HAVE_SYS_IOCTL_H #include diff --git a/libguile/posix.c b/libguile/posix.c index 3e03c86c0..6a940e46f 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 -#endif #ifdef LIBC_H_WITH_UNISTD_H #include diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 5f3b156c0..83f899670 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -20,10 +20,7 @@ # include #endif -#ifdef HAVE_UNISTD_H -# include -#endif - +#include #include #include #include diff --git a/libguile/random.c b/libguile/random.c index c0b04bc05..18737aa5a 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 #include #include - -#ifdef HAVE_UNISTD_H #include -#endif #include "libguile/smob.h" #include "libguile/numbers.h" diff --git a/libguile/rw.c b/libguile/rw.c index a9b4a329a..a64e6f828 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2006, 2009, 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 -#endif #ifdef HAVE_IO_H #include #endif diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 97435f49c..f404b6a27 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 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 /* for mingw */ #endif -#ifdef HAVE_UNISTD_H #include -#endif #ifdef HAVE_SYS_TIME_H #include diff --git a/libguile/script.c b/libguile/script.c index 83daf8ac1..0d7b28fa8 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1994-1998, 2000-2011 Free Software Foundation, Inc. +/* Copyright (C) 1994-1998, 2000-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 * as published by the Free Software Foundation; either version 3 of @@ -46,9 +46,7 @@ #include #endif -#ifdef HAVE_UNISTD_H #include /* for X_OK define */ -#endif #ifdef HAVE_IO_H #include diff --git a/libguile/simpos.c b/libguile/simpos.c index 8859d4f15..6b3f51bb2 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 Free Software Foundation, Inc. + * 2010, 2012, 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 #endif -#ifdef HAVE_UNISTD_H #include -#endif #if HAVE_SYS_WAIT_H # include #endif diff --git a/libguile/socket.c b/libguile/socket.c index 09f4831cd..c0faae1aa 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -33,9 +33,7 @@ #ifdef HAVE_STRING_H #include #endif -#ifdef HAVE_UNISTD_H #include -#endif #include #include #ifdef HAVE_UNIX_DOMAIN_SOCKETS diff --git a/libguile/stime.c b/libguile/stime.c index 78539d9cd..f430ca492 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 -#endif #ifdef HAVE_CLOCK_GETTIME diff --git a/libguile/strports.c b/libguile/strports.c index 582b5e91d..f30601972 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 Free Software Foundation, Inc. + * 2009, 2010, 2011, 2012, 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 -#ifdef HAVE_UNISTD_H #include -#endif #include "libguile/bytevectors.h" #include "libguile/eval.h" diff --git a/libguile/threads.c b/libguile/threads.c index 8fddbce89..15e491990 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 - * 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 @@ -28,9 +28,7 @@ #include "libguile/_scm.h" #include -#if HAVE_UNISTD_H #include -#endif #include #ifdef HAVE_STRING_H -- cgit v1.2.3 From 6587bcfa53f620142e4f712ad347a25e3c33a9bc Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 27 Feb 2014 21:31:57 -0500 Subject: SRFI-18: Export 'current-thread'. Fixes . Reported by Xin Wang . * module/srfi/srfi-18.scm: Reexport 'current-thread'. * THANKS: Add "Xin Wang" to fixes section. --- THANKS | 1 + module/srfi/srfi-18.scm | 6 +++--- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/THANKS b/THANKS index ddb11c14d..faef9b6a6 100644 --- a/THANKS +++ b/THANKS @@ -183,6 +183,7 @@ For fixes or providing information which led to a fix: Andreas Vögele Michael Talbot-Wilson Michael Tuexen + Xin Wang Thomas Wawrzinek Mark H. Weaver Göran Weinholt diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 4921a95d7..5b5b2a686 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -1,6 +1,6 @@ ;;; srfi-18.scm --- Multithreading support -;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2008, 2009, 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 @@ -82,7 +82,7 @@ uncaught-exception? uncaught-exception-reason ) - :re-export (thread? mutex? condition-variable?) + :re-export (current-thread thread? mutex? condition-variable?) :replace (current-time make-thread make-mutex @@ -380,4 +380,4 @@ (cons (inexact->exact fx) (inexact->exact (truncate (* (- x fx) 1000000))))))) -;; srfi-18.scm ends here \ No newline at end of file +;; srfi-18.scm ends here -- cgit v1.2.3 From e1bb79fde62e678c0f8ceb32c7edd2dab0201a5c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 28 Feb 2014 21:00:11 +0100 Subject: build: Make c-tokenize.c build on non-GNU systems. * libguile/c-tokenize.lex: Add %top directive to include first. This fixes builds on systems that use Gnulib's and similar replacements. See for an example. --- libguile/c-tokenize.lex | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/libguile/c-tokenize.lex b/libguile/c-tokenize.lex index 856224e46..a64b61da4 100644 --- a/libguile/c-tokenize.lex +++ b/libguile/c-tokenize.lex @@ -1,3 +1,9 @@ +%top{ +/* Include before anything else because Gnulib headers such + as rely on it. */ +#include +} + %option noyywrap %option nounput %pointer @@ -14,8 +20,6 @@ FLOQUAL (f|F|l|L) INTQUAL (l|L|ll|LL|lL|Ll|u|U) %{ -#include - #include #include #include -- cgit v1.2.3 From d5f7b6678f40be433bd806309665a36494030293 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 1 Mar 2014 19:03:35 -0500 Subject: Add missing files to the test-suite Makefile. * test-suite/Makefile.am (SCM_TESTS): Add "tests/compiler.test", "tests/encoding-escapes.test", "tests/encoding-iso88591.test", "tests/encoding-iso88597.test", "tests/encoding-utf8.test", "tests/pairs.test", "tests/records.test", "tests/sort.test", "tests/srfi-17.test", "tests/srfi-18.test", "tests/srfi-98.test", "tests/streams.test", "tests/vectors.test", and "tests/web-client.test". --- test-suite/Makefile.am | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 41feb1570..a050f830e 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -1,7 +1,7 @@ ## Process this file with automake to produce Makefile.in. ## ## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, -## 2010, 2011, 2012, 2013 Software Foundation, Inc. +## 2010, 2011, 2012, 2013, 2014 Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -37,11 +37,16 @@ SCM_TESTS = tests/00-initial-env.test \ tests/chars.test \ tests/coding.test \ tests/common-list.test \ + tests/compiler.test \ tests/control.test \ tests/continuations.test \ tests/coverage.test \ tests/cse.test \ tests/curried-definitions.test \ + tests/encoding-escapes.test \ + tests/encoding-iso88591.test \ + tests/encoding-iso88597.test \ + tests/encoding-utf8.test \ tests/ecmascript.test \ tests/elisp.test \ tests/elisp-compiler.test \ @@ -77,6 +82,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/numbers.test \ tests/optargs.test \ tests/options.test \ + tests/pairs.test \ tests/parameters.test \ tests/peval.test \ tests/print.test \ @@ -111,10 +117,12 @@ SCM_TESTS = tests/00-initial-env.test \ tests/ramap.test \ tests/rdelim.test \ tests/reader.test \ + tests/records.test \ tests/receive.test \ tests/regexp.test \ tests/session.test \ tests/signals.test \ + tests/sort.test \ tests/srcprop.test \ tests/srfi-1.test \ tests/srfi-6.test \ @@ -122,6 +130,8 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-11.test \ tests/srfi-13.test \ tests/srfi-14.test \ + tests/srfi-17.test \ + tests/srfi-18.test \ tests/srfi-19.test \ tests/srfi-26.test \ tests/srfi-27.test \ @@ -140,11 +150,13 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-67.test \ tests/srfi-69.test \ tests/srfi-88.test \ + tests/srfi-98.test \ tests/srfi-105.test \ tests/srfi-111.test \ tests/srfi-4.test \ tests/srfi-9.test \ tests/statprof.test \ + tests/streams.test \ tests/strings.test \ tests/structs.test \ tests/sxml.fold.test \ @@ -165,8 +177,10 @@ SCM_TESTS = tests/00-initial-env.test \ tests/tree-il.test \ tests/types.test \ tests/version.test \ + tests/vectors.test \ tests/vlist.test \ tests/weaks.test \ + tests/web-client.test \ tests/web-http.test \ tests/web-request.test \ tests/web-response.test \ -- cgit v1.2.3 From bf0d59e54de22f0a2e384b0fea2aa039769676fb Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 3 Mar 2014 17:20:03 -0500 Subject: SRFI-19: Update the table of leap seconds. * module/srfi/srfi-19.scm (leap-second-table): Update to include the two most recent leap seconds. --- module/srfi/srfi-19.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index c0a27b1a2..6d86ee638 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -1,6 +1,7 @@ ;;; srfi-19.scm --- Time/Date Library -;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 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 @@ -171,7 +172,7 @@ ;; A table of leap seconds ;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat ;; and update as necessary. -;; this procedures reads the file in the abover +;; this procedures reads the file in the above ;; format and creates the leap second table ;; it also calls the almost standard, but not R5 procedures read-line ;; & open-input-string @@ -202,7 +203,9 @@ ;; each entry is (tai seconds since epoch . # seconds to subtract for utc) ;; note they go higher to lower, and end in 1972. (define leap-second-table - '((1136073600 . 33) + '((1341100800 . 35) + (1230768000 . 34) + (1136073600 . 33) (915148800 . 32) (867715200 . 31) (820454400 . 30) -- cgit v1.2.3 From c3c3032608c9658c5dc5019d85446b6a1c2f7fcc Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 6 Mar 2014 17:17:11 -0500 Subject: Make snarfing tools more robust to varied C preprocessor behavior. * libguile/guile-snarf.in (modern_snarf): Rewrite sed script to cope with newlines in the snarfed code segments, or multiple code segments on the same line. * module/scripts/snarf-check-and-output-texi.scm (process-stream): Strip all 'hash' tokens from the stream. (do-command): Remove special cases that handled 'hash' tokens in a few places. --- libguile/guile-snarf.in | 19 +++++++++++-------- module/scripts/snarf-check-and-output-texi.scm | 15 ++------------- 2 files changed, 13 insertions(+), 21 deletions(-) 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/module/scripts/snarf-check-and-output-texi.scm b/module/scripts/snarf-check-and-output-texi.scm index 6ca07a1f4..82d71f4a9 100644 --- a/module/scripts/snarf-check-and-output-texi.scm +++ b/module/scripts/snarf-check-and-output-texi.scm @@ -1,6 +1,6 @@ ;;; snarf-check-and-output-texi --- called by the doc snarfer. -;; Copyright (C) 2001, 2002, 2006, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2006, 2011, 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 @@ -63,7 +63,7 @@ (let loop ((s s)) (cond ((stream-null? s) #t) - ((eq? 'eol (stream-car s)) + ((memq (stream-car s) '(eol hash)) (loop (stream-cdr s))) (else (cons (stream-car s) (stream-cdr s)))))) (port->stream port read))))) @@ -265,17 +265,6 @@ (set! *file* file) (set! *line* line)) - ;; newer gccs like to throw around more location markers into the - ;; preprocessed source; these (hash . hash) bits are what they translate to - ;; in snarfy terms. - (('location ('string . file) ('int . line) ('hash . 'hash)) - (set! *file* file) - (set! *line* line)) - - (('location ('hash . 'hash) ('string . file) ('int . line) ('hash . 'hash)) - (set! *file* file) - (set! *line* line)) - (('arglist rest ...) (set! *args* (do-arglist rest))) -- cgit v1.2.3 From b8d7aacd682ce70d496fecf1626365c72132ada0 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 6 Mar 2014 23:56:48 -0500 Subject: snarf.h: Declare static const function name vars as SCM_UNUSED. * libguile/snarf.h (SCM_DEFINE_GSUBR, SCM_DEFINE, SCM_PRIMITIVE_GENERIC, SCM_DEFINE_PUBLIC, SCM_PROC, SCM_REGISTER_PROC, SCM_GPROC): Declare static const function name variables as SCM_UNUSED to avoid spurious warnings. --- libguile/snarf.h | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/libguile/snarf.h b/libguile/snarf.h index 1c072babb..1655e2c8d 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 Free Software Foundation, Inc. + * 2004, 2006, 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 @@ -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(\ @@ -103,7 +103,7 @@ SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) #define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \ SCM_SYMBOL (scm_i_paste (FNAME, __name), PRIMNAME); \ SCM_SNARF_HERE( \ - static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \ + SCM_UNUSED static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \ SCM_API SCM FNAME ARGLIST; \ SCM_IMMUTABLE_POINTER (scm_i_paste (FNAME, __subr_foreign), \ (scm_t_bits) &FNAME); /* the subr */ \ @@ -141,7 +141,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\ )\ @@ -155,7 +155,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(\ @@ -166,12 +166,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, \ @@ -179,7 +179,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? */ \ -- cgit v1.2.3 From ce0ba9d087fd5b03d85a64deddaf3c59bd136a3d Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 6 Mar 2014 23:59:56 -0500 Subject: chars.c: Remove duplicate 'const' specifiers. * libguile/chars.c (scm_r5rs_charnums, scm_r6rs_charnums) (scm_r7rs_charnums, scm_C0_control_charnums, scm_alt_charnums): Remove duplicate 'const' specifiers. --- libguile/chars.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/libguile/chars.c b/libguile/chars.c index 697a5c401..e1aab1d2a 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 }; -- cgit v1.2.3 From de7aa61ac48811610b1b99005ada2464cf1a96f1 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 7 Mar 2014 04:21:46 -0500 Subject: Improve compliance with C standards regarding signed integer shifts. * configure.ac: Add -fwrapv when using GCC (or compatible), if supported. * libguile/numbers.h (SCM_I_MAKINUM): Cast to scm_t_bits (unsigned) before shifting, to avoid undefined behavior. --- configure.ac | 9 +++++---- libguile/numbers.h | 4 ++-- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/configure.ac b/configure.ac index e99b27290..a5cb4b867 100644 --- a/configure.ac +++ b/configure.ac @@ -1516,7 +1516,8 @@ AC_SUBST(HOST_CC) GUILE_CHECK_GUILE_FOR_BUILD -## If we're using GCC, ask for aggressive warnings. +## If we're using GCC, add flags to reduce strictness of undefined +## behavior, and ask for aggressive warnings. GCC_CFLAGS="" case "$GCC" in yes ) @@ -1526,13 +1527,13 @@ case "$GCC" in ## -Wundef was removed because Gnulib prevented it (see ## .) - ## Build with `-fno-strict-aliasing' to prevent miscompilation on - ## some platforms. See + ## Build with `-fno-strict-aliasing' and `-fwrapv' to prevent + ## miscompilation on some platforms. See ## . POTENTIAL_GCC_CFLAGS="-Wall -Wmissing-prototypes \ -Wdeclaration-after-statement -Wpointer-arith \ - -Wswitch-enum -fno-strict-aliasing" + -Wswitch-enum -fno-strict-aliasing -fwrapv" # Do this here so we don't screw up any of the tests above that might # not be "warning free" if test "${GUILE_ERROR_ON_WARNING}" = yes diff --git a/libguile/numbers.h b/libguile/numbers.h index 4d977dc3c..b4202f26a 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 @@ -60,7 +60,7 @@ typedef scm_t_int32 scm_t_wchar; #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)) + (SCM_PACK ((((scm_t_bits) (x)) << 2) + scm_tc2_int)) #define SCM_I_INUM(x) (SCM_SRS ((scm_t_signed_bits) SCM_UNPACK (x), 2)) /* SCM_FIXABLE is true if its long argument can be encoded in an SCM_INUM. */ -- cgit v1.2.3 From 8f7887d61604073528544ccb09849ca0e2f4df78 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 12 Mar 2014 00:02:01 +0100 Subject: Provide glthread/lock.h implementation in terms of Guile threads. Fixes . Thanks to Paul Eggert for the suggestion. * m4/gnulib-cache.m4: Avoid 'lock' module. * m4/lock.m4, m4/threadlib.m4, lib/glthread/threadlib.c, lib/glthread/lock.c: Remove. * lib/glthread/lock.h: Rewrite in terms of libguile/threads.h. * m4/gnulib-common.m4, m4/gnulib-comp.m4, lib/Makefile.am, lib/unistd.in.h, maint.mk : Update, from Gnulib v0.1-92-g546ff82. * configure.ac (GNULIB_LOCK): Define 'GNULIB_LOCK'. Define 'USE_POSIX_THREADS' when building with pthread support. * Makefile.am (noinst_HEADERS): New variable. (BUILT_SOURCES): Add libguile/scmconfig.h. (libguile/scmconfig.h): New target. --- Makefile.am | 15 +- configure.ac | 14 +- lib/Makefile.am | 17 +- lib/glthread/lock.c | 1057 ---------------------------------------------- lib/glthread/lock.h | 955 ++--------------------------------------- lib/glthread/threadlib.c | 73 ---- lib/unistd.in.h | 15 + m4/gnulib-cache.m4 | 4 +- m4/gnulib-common.m4 | 56 +++ m4/gnulib-comp.m4 | 12 +- m4/lock.m4 | 42 -- m4/threadlib.m4 | 371 ---------------- maint.mk | 35 +- 13 files changed, 151 insertions(+), 2515 deletions(-) delete mode 100644 lib/glthread/lock.c delete mode 100644 lib/glthread/threadlib.c delete mode 100644 m4/lock.m4 delete mode 100644 m4/threadlib.m4 diff --git a/Makefile.am b/Makefile.am index 2ed837046..8f9e014c7 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,7 +1,8 @@ ## Process this file with automake to produce Makefile.in. ## ## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007, -## 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +## 2008, 2009, 2010, 2011, 2012, 2013, +## 2014 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -45,6 +46,16 @@ libguileinclude_HEADERS = libguile.h schemelibdir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION) schemelib_DATA = libguile/guile-procedures.txt +# Our own implementation of Gnulib's lock interface. +noinst_HEADERS = lib/glthread/lock.h + +# Our lib/glthreads/lock.h header indirectly includes +# libguile/scmconfig.h. Make sure it is built before we recurse into +# lib/. +BUILT_SOURCES = libguile/scmconfig.h +libguile/scmconfig.h: + $(MAKE) -C libguile scmconfig.h + # Build it from here so that all the modules are compiled by the time we # build it. libguile/guile-procedures.txt: libguile/guile-procedures.texi @@ -94,7 +105,7 @@ gen-ChangeLog: mv $(distdir)/cl-t $(distdir)/ChangeLog; \ fi -BUILT_SOURCES = $(top_srcdir)/.version +BUILT_SOURCES += $(top_srcdir)/.version $(top_srcdir)/.version: echo $(VERSION) > $@-t && mv $@-t $@ gen-tarball-version: diff --git a/configure.ac b/configure.ac index a5cb4b867..947296ba7 100644 --- a/configure.ac +++ b/configure.ac @@ -76,6 +76,13 @@ AM_PROG_AR dnl Gnulib. gl_INIT +dnl We provide our own lib/glthread/lock.h, so let other Gnulib modules +dnl know that we have it. This allows them to be compiled with adequate +dnl locking support. See . +AC_DEFINE([GNULIB_LOCK], [1], + [Define to allow Gnulib modules to use Guile's locks.]) + + AC_PROG_CC_C89 # for per-target cflags in the libguile subdir @@ -1437,10 +1444,13 @@ AM_CONDITIONAL([BUILD_PTHREAD_SUPPORT], [test "x$build_pthread_support" = "xyes"]) -## Check whether pthread_attr_getstack works for the main thread - if test "$with_threads" = pthreads; then +dnl Normally Gnulib's 'threadlib' module would define this macro, but +dnl since we don't use it, define it by ourselves. +AC_DEFINE([USE_POSIX_THREADS], [1], + [Define to let Gnulib modules know that we use POSIX threads.]) + AC_MSG_CHECKING([whether pthread_attr_getstack works for the main thread]) old_CFLAGS="$CFLAGS" CFLAGS="$PTHREAD_CFLAGS $CFLAGS" diff --git a/lib/Makefile.am b/lib/Makefile.am index 8b643c72b..5d9c902fc 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar AUTOMAKE_OPTIONS = 1.9.6 gnits subdir-objects @@ -69,7 +69,6 @@ libgnu_la_LDFLAGS += $(LOG1P_LIBM) libgnu_la_LDFLAGS += $(LOG_LIBM) libgnu_la_LDFLAGS += $(LTLIBICONV) libgnu_la_LDFLAGS += $(LTLIBINTL) -libgnu_la_LDFLAGS += $(LTLIBTHREAD) libgnu_la_LDFLAGS += $(LTLIBUNISTRING) libgnu_la_LDFLAGS += $(ROUND_LIBM) libgnu_la_LDFLAGS += $(SERVENT_LIB) @@ -1050,12 +1049,6 @@ EXTRA_libgnu_la_SOURCES += localeconv.c ## end gnulib module localeconv -## begin gnulib module lock - -libgnu_la_SOURCES += glthread/lock.h glthread/lock.c - -## end gnulib module lock - ## begin gnulib module log @@ -2799,14 +2792,6 @@ EXTRA_DIST += tempname.h ## end gnulib module tempname -## begin gnulib module threadlib - -libgnu_la_SOURCES += glthread/threadlib.c - -EXTRA_DIST += $(top_srcdir)/build-aux/config.rpath - -## end gnulib module threadlib - ## begin gnulib module time BUILT_SOURCES += time.h diff --git a/lib/glthread/lock.c b/lib/glthread/lock.c deleted file mode 100644 index 0454cc251..000000000 --- a/lib/glthread/lock.c +++ /dev/null @@ -1,1057 +0,0 @@ -/* Locking in multithreaded situations. - Copyright (C) 2005-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 published by - the Free Software Foundation; either version 2, 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 Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program; if not, see . */ - -/* Written by Bruno Haible , 2005. - Based on GCC's gthr-posix.h, gthr-posix95.h, gthr-solaris.h, - gthr-win32.h. */ - -#include - -#include "glthread/lock.h" - -/* ========================================================================= */ - -#if USE_POSIX_THREADS - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -# if HAVE_PTHREAD_RWLOCK - -# if !defined PTHREAD_RWLOCK_INITIALIZER - -int -glthread_rwlock_init_multithreaded (gl_rwlock_t *lock) -{ - int err; - - err = pthread_rwlock_init (&lock->rwlock, NULL); - if (err != 0) - return err; - lock->initialized = 1; - return 0; -} - -int -glthread_rwlock_rdlock_multithreaded (gl_rwlock_t *lock) -{ - if (!lock->initialized) - { - int err; - - err = pthread_mutex_lock (&lock->guard); - if (err != 0) - return err; - if (!lock->initialized) - { - err = glthread_rwlock_init_multithreaded (lock); - if (err != 0) - { - pthread_mutex_unlock (&lock->guard); - return err; - } - } - err = pthread_mutex_unlock (&lock->guard); - if (err != 0) - return err; - } - return pthread_rwlock_rdlock (&lock->rwlock); -} - -int -glthread_rwlock_wrlock_multithreaded (gl_rwlock_t *lock) -{ - if (!lock->initialized) - { - int err; - - err = pthread_mutex_lock (&lock->guard); - if (err != 0) - return err; - if (!lock->initialized) - { - err = glthread_rwlock_init_multithreaded (lock); - if (err != 0) - { - pthread_mutex_unlock (&lock->guard); - return err; - } - } - err = pthread_mutex_unlock (&lock->guard); - if (err != 0) - return err; - } - return pthread_rwlock_wrlock (&lock->rwlock); -} - -int -glthread_rwlock_unlock_multithreaded (gl_rwlock_t *lock) -{ - if (!lock->initialized) - return EINVAL; - return pthread_rwlock_unlock (&lock->rwlock); -} - -int -glthread_rwlock_destroy_multithreaded (gl_rwlock_t *lock) -{ - int err; - - if (!lock->initialized) - return EINVAL; - err = pthread_rwlock_destroy (&lock->rwlock); - if (err != 0) - return err; - lock->initialized = 0; - return 0; -} - -# endif - -# else - -int -glthread_rwlock_init_multithreaded (gl_rwlock_t *lock) -{ - int err; - - err = pthread_mutex_init (&lock->lock, NULL); - if (err != 0) - return err; - err = pthread_cond_init (&lock->waiting_readers, NULL); - if (err != 0) - return err; - err = pthread_cond_init (&lock->waiting_writers, NULL); - if (err != 0) - return err; - lock->waiting_writers_count = 0; - lock->runcount = 0; - return 0; -} - -int -glthread_rwlock_rdlock_multithreaded (gl_rwlock_t *lock) -{ - int err; - - err = pthread_mutex_lock (&lock->lock); - if (err != 0) - return err; - /* Test whether only readers are currently running, and whether the runcount - field will not overflow. */ - /* POSIX says: "It is implementation-defined whether the calling thread - acquires the lock when a writer does not hold the lock and there are - writers blocked on the lock." Let's say, no: give the writers a higher - priority. */ - while (!(lock->runcount + 1 > 0 && lock->waiting_writers_count == 0)) - { - /* This thread has to wait for a while. Enqueue it among the - waiting_readers. */ - err = pthread_cond_wait (&lock->waiting_readers, &lock->lock); - if (err != 0) - { - pthread_mutex_unlock (&lock->lock); - return err; - } - } - lock->runcount++; - return pthread_mutex_unlock (&lock->lock); -} - -int -glthread_rwlock_wrlock_multithreaded (gl_rwlock_t *lock) -{ - int err; - - err = pthread_mutex_lock (&lock->lock); - if (err != 0) - return err; - /* Test whether no readers or writers are currently running. */ - while (!(lock->runcount == 0)) - { - /* This thread has to wait for a while. Enqueue it among the - waiting_writers. */ - lock->waiting_writers_count++; - err = pthread_cond_wait (&lock->waiting_writers, &lock->lock); - if (err != 0) - { - lock->waiting_writers_count--; - pthread_mutex_unlock (&lock->lock); - return err; - } - lock->waiting_writers_count--; - } - lock->runcount--; /* runcount becomes -1 */ - return pthread_mutex_unlock (&lock->lock); -} - -int -glthread_rwlock_unlock_multithreaded (gl_rwlock_t *lock) -{ - int err; - - err = pthread_mutex_lock (&lock->lock); - if (err != 0) - return err; - if (lock->runcount < 0) - { - /* Drop a writer lock. */ - if (!(lock->runcount == -1)) - { - pthread_mutex_unlock (&lock->lock); - return EINVAL; - } - lock->runcount = 0; - } - else - { - /* Drop a reader lock. */ - if (!(lock->runcount > 0)) - { - pthread_mutex_unlock (&lock->lock); - return EINVAL; - } - lock->runcount--; - } - if (lock->runcount == 0) - { - /* POSIX recommends that "write locks shall take precedence over read - locks", to avoid "writer starvation". */ - if (lock->waiting_writers_count > 0) - { - /* Wake up one of the waiting writers. */ - err = pthread_cond_signal (&lock->waiting_writers); - if (err != 0) - { - pthread_mutex_unlock (&lock->lock); - return err; - } - } - else - { - /* Wake up all waiting readers. */ - err = pthread_cond_broadcast (&lock->waiting_readers); - if (err != 0) - { - pthread_mutex_unlock (&lock->lock); - return err; - } - } - } - return pthread_mutex_unlock (&lock->lock); -} - -int -glthread_rwlock_destroy_multithreaded (gl_rwlock_t *lock) -{ - int err; - - err = pthread_mutex_destroy (&lock->lock); - if (err != 0) - return err; - err = pthread_cond_destroy (&lock->waiting_readers); - if (err != 0) - return err; - err = pthread_cond_destroy (&lock->waiting_writers); - if (err != 0) - return err; - return 0; -} - -# endif - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -# if HAVE_PTHREAD_MUTEX_RECURSIVE - -# if defined PTHREAD_RECURSIVE_MUTEX_INITIALIZER || defined PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP - -int -glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock) -{ - pthread_mutexattr_t attributes; - int err; - - err = pthread_mutexattr_init (&attributes); - if (err != 0) - return err; - err = pthread_mutexattr_settype (&attributes, PTHREAD_MUTEX_RECURSIVE); - if (err != 0) - { - pthread_mutexattr_destroy (&attributes); - return err; - } - err = pthread_mutex_init (lock, &attributes); - if (err != 0) - { - pthread_mutexattr_destroy (&attributes); - return err; - } - err = pthread_mutexattr_destroy (&attributes); - if (err != 0) - return err; - return 0; -} - -# else - -int -glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock) -{ - pthread_mutexattr_t attributes; - int err; - - err = pthread_mutexattr_init (&attributes); - if (err != 0) - return err; - err = pthread_mutexattr_settype (&attributes, PTHREAD_MUTEX_RECURSIVE); - if (err != 0) - { - pthread_mutexattr_destroy (&attributes); - return err; - } - err = pthread_mutex_init (&lock->recmutex, &attributes); - if (err != 0) - { - pthread_mutexattr_destroy (&attributes); - return err; - } - err = pthread_mutexattr_destroy (&attributes); - if (err != 0) - return err; - lock->initialized = 1; - return 0; -} - -int -glthread_recursive_lock_lock_multithreaded (gl_recursive_lock_t *lock) -{ - if (!lock->initialized) - { - int err; - - err = pthread_mutex_lock (&lock->guard); - if (err != 0) - return err; - if (!lock->initialized) - { - err = glthread_recursive_lock_init_multithreaded (lock); - if (err != 0) - { - pthread_mutex_unlock (&lock->guard); - return err; - } - } - err = pthread_mutex_unlock (&lock->guard); - if (err != 0) - return err; - } - return pthread_mutex_lock (&lock->recmutex); -} - -int -glthread_recursive_lock_unlock_multithreaded (gl_recursive_lock_t *lock) -{ - if (!lock->initialized) - return EINVAL; - return pthread_mutex_unlock (&lock->recmutex); -} - -int -glthread_recursive_lock_destroy_multithreaded (gl_recursive_lock_t *lock) -{ - int err; - - if (!lock->initialized) - return EINVAL; - err = pthread_mutex_destroy (&lock->recmutex); - if (err != 0) - return err; - lock->initialized = 0; - return 0; -} - -# endif - -# else - -int -glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock) -{ - int err; - - err = pthread_mutex_init (&lock->mutex, NULL); - if (err != 0) - return err; - lock->owner = (pthread_t) 0; - lock->depth = 0; - return 0; -} - -int -glthread_recursive_lock_lock_multithreaded (gl_recursive_lock_t *lock) -{ - pthread_t self = pthread_self (); - if (lock->owner != self) - { - int err; - - err = pthread_mutex_lock (&lock->mutex); - if (err != 0) - return err; - lock->owner = self; - } - if (++(lock->depth) == 0) /* wraparound? */ - { - lock->depth--; - return EAGAIN; - } - return 0; -} - -int -glthread_recursive_lock_unlock_multithreaded (gl_recursive_lock_t *lock) -{ - if (lock->owner != pthread_self ()) - return EPERM; - if (lock->depth == 0) - return EINVAL; - if (--(lock->depth) == 0) - { - lock->owner = (pthread_t) 0; - return pthread_mutex_unlock (&lock->mutex); - } - else - return 0; -} - -int -glthread_recursive_lock_destroy_multithreaded (gl_recursive_lock_t *lock) -{ - if (lock->owner != (pthread_t) 0) - return EBUSY; - return pthread_mutex_destroy (&lock->mutex); -} - -# endif - -/* -------------------------- gl_once_t datatype -------------------------- */ - -static const pthread_once_t fresh_once = PTHREAD_ONCE_INIT; - -int -glthread_once_singlethreaded (pthread_once_t *once_control) -{ - /* We don't know whether pthread_once_t is an integer type, a floating-point - type, a pointer type, or a structure type. */ - char *firstbyte = (char *)once_control; - if (*firstbyte == *(const char *)&fresh_once) - { - /* First time use of once_control. Invert the first byte. */ - *firstbyte = ~ *(const char *)&fresh_once; - return 1; - } - else - return 0; -} - -#endif - -/* ========================================================================= */ - -#if USE_PTH_THREADS - -/* Use the GNU Pth threads library. */ - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -/* -------------------------- gl_once_t datatype -------------------------- */ - -static void -glthread_once_call (void *arg) -{ - void (**gl_once_temp_addr) (void) = (void (**) (void)) arg; - void (*initfunction) (void) = *gl_once_temp_addr; - initfunction (); -} - -int -glthread_once_multithreaded (pth_once_t *once_control, void (*initfunction) (void)) -{ - void (*temp) (void) = initfunction; - return (!pth_once (once_control, glthread_once_call, &temp) ? errno : 0); -} - -int -glthread_once_singlethreaded (pth_once_t *once_control) -{ - /* We know that pth_once_t is an integer type. */ - if (*once_control == PTH_ONCE_INIT) - { - /* First time use of once_control. Invert the marker. */ - *once_control = ~ PTH_ONCE_INIT; - return 1; - } - else - return 0; -} - -#endif - -/* ========================================================================= */ - -#if USE_SOLARIS_THREADS - -/* Use the old Solaris threads library. */ - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -int -glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock) -{ - int err; - - err = mutex_init (&lock->mutex, USYNC_THREAD, NULL); - if (err != 0) - return err; - lock->owner = (thread_t) 0; - lock->depth = 0; - return 0; -} - -int -glthread_recursive_lock_lock_multithreaded (gl_recursive_lock_t *lock) -{ - thread_t self = thr_self (); - if (lock->owner != self) - { - int err; - - err = mutex_lock (&lock->mutex); - if (err != 0) - return err; - lock->owner = self; - } - if (++(lock->depth) == 0) /* wraparound? */ - { - lock->depth--; - return EAGAIN; - } - return 0; -} - -int -glthread_recursive_lock_unlock_multithreaded (gl_recursive_lock_t *lock) -{ - if (lock->owner != thr_self ()) - return EPERM; - if (lock->depth == 0) - return EINVAL; - if (--(lock->depth) == 0) - { - lock->owner = (thread_t) 0; - return mutex_unlock (&lock->mutex); - } - else - return 0; -} - -int -glthread_recursive_lock_destroy_multithreaded (gl_recursive_lock_t *lock) -{ - if (lock->owner != (thread_t) 0) - return EBUSY; - return mutex_destroy (&lock->mutex); -} - -/* -------------------------- gl_once_t datatype -------------------------- */ - -int -glthread_once_multithreaded (gl_once_t *once_control, void (*initfunction) (void)) -{ - if (!once_control->inited) - { - int err; - - /* Use the mutex to guarantee that if another thread is already calling - the initfunction, this thread waits until it's finished. */ - err = mutex_lock (&once_control->mutex); - if (err != 0) - return err; - if (!once_control->inited) - { - once_control->inited = 1; - initfunction (); - } - return mutex_unlock (&once_control->mutex); - } - else - return 0; -} - -int -glthread_once_singlethreaded (gl_once_t *once_control) -{ - /* We know that gl_once_t contains an integer type. */ - if (!once_control->inited) - { - /* First time use of once_control. Invert the marker. */ - once_control->inited = ~ 0; - return 1; - } - else - return 0; -} - -#endif - -/* ========================================================================= */ - -#if USE_WINDOWS_THREADS - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -void -glthread_lock_init_func (gl_lock_t *lock) -{ - InitializeCriticalSection (&lock->lock); - lock->guard.done = 1; -} - -int -glthread_lock_lock_func (gl_lock_t *lock) -{ - if (!lock->guard.done) - { - if (InterlockedIncrement (&lock->guard.started) == 0) - /* This thread is the first one to need this lock. Initialize it. */ - glthread_lock_init (lock); - else - /* Yield the CPU while waiting for another thread to finish - initializing this lock. */ - while (!lock->guard.done) - Sleep (0); - } - EnterCriticalSection (&lock->lock); - return 0; -} - -int -glthread_lock_unlock_func (gl_lock_t *lock) -{ - if (!lock->guard.done) - return EINVAL; - LeaveCriticalSection (&lock->lock); - return 0; -} - -int -glthread_lock_destroy_func (gl_lock_t *lock) -{ - if (!lock->guard.done) - return EINVAL; - DeleteCriticalSection (&lock->lock); - lock->guard.done = 0; - return 0; -} - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -/* In this file, the waitqueues are implemented as circular arrays. */ -#define gl_waitqueue_t gl_carray_waitqueue_t - -static void -gl_waitqueue_init (gl_waitqueue_t *wq) -{ - wq->array = NULL; - wq->count = 0; - wq->alloc = 0; - wq->offset = 0; -} - -/* Enqueues the current thread, represented by an event, in a wait queue. - Returns INVALID_HANDLE_VALUE if an allocation failure occurs. */ -static HANDLE -gl_waitqueue_add (gl_waitqueue_t *wq) -{ - HANDLE event; - unsigned int index; - - if (wq->count == wq->alloc) - { - unsigned int new_alloc = 2 * wq->alloc + 1; - HANDLE *new_array = - (HANDLE *) realloc (wq->array, new_alloc * sizeof (HANDLE)); - if (new_array == NULL) - /* No more memory. */ - return INVALID_HANDLE_VALUE; - /* Now is a good opportunity to rotate the array so that its contents - starts at offset 0. */ - if (wq->offset > 0) - { - unsigned int old_count = wq->count; - unsigned int old_alloc = wq->alloc; - unsigned int old_offset = wq->offset; - unsigned int i; - if (old_offset + old_count > old_alloc) - { - unsigned int limit = old_offset + old_count - old_alloc; - for (i = 0; i < limit; i++) - new_array[old_alloc + i] = new_array[i]; - } - for (i = 0; i < old_count; i++) - new_array[i] = new_array[old_offset + i]; - wq->offset = 0; - } - wq->array = new_array; - wq->alloc = new_alloc; - } - /* Whether the created event is a manual-reset one or an auto-reset one, - does not matter, since we will wait on it only once. */ - event = CreateEvent (NULL, TRUE, FALSE, NULL); - if (event == INVALID_HANDLE_VALUE) - /* No way to allocate an event. */ - return INVALID_HANDLE_VALUE; - index = wq->offset + wq->count; - if (index >= wq->alloc) - index -= wq->alloc; - wq->array[index] = event; - wq->count++; - return event; -} - -/* Notifies the first thread from a wait queue and dequeues it. */ -static void -gl_waitqueue_notify_first (gl_waitqueue_t *wq) -{ - SetEvent (wq->array[wq->offset + 0]); - wq->offset++; - wq->count--; - if (wq->count == 0 || wq->offset == wq->alloc) - wq->offset = 0; -} - -/* Notifies all threads from a wait queue and dequeues them all. */ -static void -gl_waitqueue_notify_all (gl_waitqueue_t *wq) -{ - unsigned int i; - - for (i = 0; i < wq->count; i++) - { - unsigned int index = wq->offset + i; - if (index >= wq->alloc) - index -= wq->alloc; - SetEvent (wq->array[index]); - } - wq->count = 0; - wq->offset = 0; -} - -void -glthread_rwlock_init_func (gl_rwlock_t *lock) -{ - InitializeCriticalSection (&lock->lock); - gl_waitqueue_init (&lock->waiting_readers); - gl_waitqueue_init (&lock->waiting_writers); - lock->runcount = 0; - lock->guard.done = 1; -} - -int -glthread_rwlock_rdlock_func (gl_rwlock_t *lock) -{ - if (!lock->guard.done) - { - if (InterlockedIncrement (&lock->guard.started) == 0) - /* This thread is the first one to need this lock. Initialize it. */ - glthread_rwlock_init (lock); - else - /* Yield the CPU while waiting for another thread to finish - initializing this lock. */ - while (!lock->guard.done) - Sleep (0); - } - EnterCriticalSection (&lock->lock); - /* Test whether only readers are currently running, and whether the runcount - field will not overflow. */ - if (!(lock->runcount + 1 > 0)) - { - /* This thread has to wait for a while. Enqueue it among the - waiting_readers. */ - HANDLE event = gl_waitqueue_add (&lock->waiting_readers); - if (event != INVALID_HANDLE_VALUE) - { - DWORD result; - LeaveCriticalSection (&lock->lock); - /* Wait until another thread signals this event. */ - result = WaitForSingleObject (event, INFINITE); - if (result == WAIT_FAILED || result == WAIT_TIMEOUT) - abort (); - CloseHandle (event); - /* The thread which signalled the event already did the bookkeeping: - removed us from the waiting_readers, incremented lock->runcount. */ - if (!(lock->runcount > 0)) - abort (); - return 0; - } - else - { - /* Allocation failure. Weird. */ - do - { - LeaveCriticalSection (&lock->lock); - Sleep (1); - EnterCriticalSection (&lock->lock); - } - while (!(lock->runcount + 1 > 0)); - } - } - lock->runcount++; - LeaveCriticalSection (&lock->lock); - return 0; -} - -int -glthread_rwlock_wrlock_func (gl_rwlock_t *lock) -{ - if (!lock->guard.done) - { - if (InterlockedIncrement (&lock->guard.started) == 0) - /* This thread is the first one to need this lock. Initialize it. */ - glthread_rwlock_init (lock); - else - /* Yield the CPU while waiting for another thread to finish - initializing this lock. */ - while (!lock->guard.done) - Sleep (0); - } - EnterCriticalSection (&lock->lock); - /* Test whether no readers or writers are currently running. */ - if (!(lock->runcount == 0)) - { - /* This thread has to wait for a while. Enqueue it among the - waiting_writers. */ - HANDLE event = gl_waitqueue_add (&lock->waiting_writers); - if (event != INVALID_HANDLE_VALUE) - { - DWORD result; - LeaveCriticalSection (&lock->lock); - /* Wait until another thread signals this event. */ - result = WaitForSingleObject (event, INFINITE); - if (result == WAIT_FAILED || result == WAIT_TIMEOUT) - abort (); - CloseHandle (event); - /* The thread which signalled the event already did the bookkeeping: - removed us from the waiting_writers, set lock->runcount = -1. */ - if (!(lock->runcount == -1)) - abort (); - return 0; - } - else - { - /* Allocation failure. Weird. */ - do - { - LeaveCriticalSection (&lock->lock); - Sleep (1); - EnterCriticalSection (&lock->lock); - } - while (!(lock->runcount == 0)); - } - } - lock->runcount--; /* runcount becomes -1 */ - LeaveCriticalSection (&lock->lock); - return 0; -} - -int -glthread_rwlock_unlock_func (gl_rwlock_t *lock) -{ - if (!lock->guard.done) - return EINVAL; - EnterCriticalSection (&lock->lock); - if (lock->runcount < 0) - { - /* Drop a writer lock. */ - if (!(lock->runcount == -1)) - abort (); - lock->runcount = 0; - } - else - { - /* Drop a reader lock. */ - if (!(lock->runcount > 0)) - { - LeaveCriticalSection (&lock->lock); - return EPERM; - } - lock->runcount--; - } - if (lock->runcount == 0) - { - /* POSIX recommends that "write locks shall take precedence over read - locks", to avoid "writer starvation". */ - if (lock->waiting_writers.count > 0) - { - /* Wake up one of the waiting writers. */ - lock->runcount--; - gl_waitqueue_notify_first (&lock->waiting_writers); - } - else - { - /* Wake up all waiting readers. */ - lock->runcount += lock->waiting_readers.count; - gl_waitqueue_notify_all (&lock->waiting_readers); - } - } - LeaveCriticalSection (&lock->lock); - return 0; -} - -int -glthread_rwlock_destroy_func (gl_rwlock_t *lock) -{ - if (!lock->guard.done) - return EINVAL; - if (lock->runcount != 0) - return EBUSY; - DeleteCriticalSection (&lock->lock); - if (lock->waiting_readers.array != NULL) - free (lock->waiting_readers.array); - if (lock->waiting_writers.array != NULL) - free (lock->waiting_writers.array); - lock->guard.done = 0; - return 0; -} - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -void -glthread_recursive_lock_init_func (gl_recursive_lock_t *lock) -{ - lock->owner = 0; - lock->depth = 0; - InitializeCriticalSection (&lock->lock); - lock->guard.done = 1; -} - -int -glthread_recursive_lock_lock_func (gl_recursive_lock_t *lock) -{ - if (!lock->guard.done) - { - if (InterlockedIncrement (&lock->guard.started) == 0) - /* This thread is the first one to need this lock. Initialize it. */ - glthread_recursive_lock_init (lock); - else - /* Yield the CPU while waiting for another thread to finish - initializing this lock. */ - while (!lock->guard.done) - Sleep (0); - } - { - DWORD self = GetCurrentThreadId (); - if (lock->owner != self) - { - EnterCriticalSection (&lock->lock); - lock->owner = self; - } - if (++(lock->depth) == 0) /* wraparound? */ - { - lock->depth--; - return EAGAIN; - } - } - return 0; -} - -int -glthread_recursive_lock_unlock_func (gl_recursive_lock_t *lock) -{ - if (lock->owner != GetCurrentThreadId ()) - return EPERM; - if (lock->depth == 0) - return EINVAL; - if (--(lock->depth) == 0) - { - lock->owner = 0; - LeaveCriticalSection (&lock->lock); - } - return 0; -} - -int -glthread_recursive_lock_destroy_func (gl_recursive_lock_t *lock) -{ - if (lock->owner != 0) - return EBUSY; - DeleteCriticalSection (&lock->lock); - lock->guard.done = 0; - return 0; -} - -/* -------------------------- gl_once_t datatype -------------------------- */ - -void -glthread_once_func (gl_once_t *once_control, void (*initfunction) (void)) -{ - if (once_control->inited <= 0) - { - if (InterlockedIncrement (&once_control->started) == 0) - { - /* This thread is the first one to come to this once_control. */ - InitializeCriticalSection (&once_control->lock); - EnterCriticalSection (&once_control->lock); - once_control->inited = 0; - initfunction (); - once_control->inited = 1; - LeaveCriticalSection (&once_control->lock); - } - else - { - /* Undo last operation. */ - InterlockedDecrement (&once_control->started); - /* Some other thread has already started the initialization. - Yield the CPU while waiting for the other thread to finish - initializing and taking the lock. */ - while (once_control->inited < 0) - Sleep (0); - if (once_control->inited <= 0) - { - /* Take the lock. This blocks until the other thread has - finished calling the initfunction. */ - EnterCriticalSection (&once_control->lock); - LeaveCriticalSection (&once_control->lock); - if (!(once_control->inited > 0)) - abort (); - } - } - } -} - -#endif - -/* ========================================================================= */ diff --git a/lib/glthread/lock.h b/lib/glthread/lock.h index 894b1fbaa..66c78a6cd 100644 --- a/lib/glthread/lock.h +++ b/lib/glthread/lock.h @@ -1,927 +1,38 @@ -/* Locking in multithreaded situations. - Copyright (C) 2005-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 published by - the Free Software Foundation; either version 2, 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 Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program; if not, see . */ - -/* Written by Bruno Haible , 2005. - Based on GCC's gthr-posix.h, gthr-posix95.h, gthr-solaris.h, - gthr-win32.h. */ - -/* This file contains locking primitives for use with a given thread library. - It does not contain primitives for creating threads or for other - synchronization primitives. - - Normal (non-recursive) locks: - Type: gl_lock_t - Declaration: gl_lock_define(extern, name) - Initializer: gl_lock_define_initialized(, name) - Initialization: gl_lock_init (name); - Taking the lock: gl_lock_lock (name); - Releasing the lock: gl_lock_unlock (name); - De-initialization: gl_lock_destroy (name); - Equivalent functions with control of error handling: - Initialization: err = glthread_lock_init (&name); - Taking the lock: err = glthread_lock_lock (&name); - Releasing the lock: err = glthread_lock_unlock (&name); - De-initialization: err = glthread_lock_destroy (&name); - - Read-Write (non-recursive) locks: - Type: gl_rwlock_t - Declaration: gl_rwlock_define(extern, name) - Initializer: gl_rwlock_define_initialized(, name) - Initialization: gl_rwlock_init (name); - Taking the lock: gl_rwlock_rdlock (name); - gl_rwlock_wrlock (name); - Releasing the lock: gl_rwlock_unlock (name); - De-initialization: gl_rwlock_destroy (name); - Equivalent functions with control of error handling: - Initialization: err = glthread_rwlock_init (&name); - Taking the lock: err = glthread_rwlock_rdlock (&name); - err = glthread_rwlock_wrlock (&name); - Releasing the lock: err = glthread_rwlock_unlock (&name); - De-initialization: err = glthread_rwlock_destroy (&name); - - Recursive locks: - Type: gl_recursive_lock_t - Declaration: gl_recursive_lock_define(extern, name) - Initializer: gl_recursive_lock_define_initialized(, name) - Initialization: gl_recursive_lock_init (name); - Taking the lock: gl_recursive_lock_lock (name); - Releasing the lock: gl_recursive_lock_unlock (name); - De-initialization: gl_recursive_lock_destroy (name); - Equivalent functions with control of error handling: - Initialization: err = glthread_recursive_lock_init (&name); - Taking the lock: err = glthread_recursive_lock_lock (&name); - Releasing the lock: err = glthread_recursive_lock_unlock (&name); - De-initialization: err = glthread_recursive_lock_destroy (&name); - - Once-only execution: - Type: gl_once_t - Initializer: gl_once_define(extern, name) - Execution: gl_once (name, initfunction); - Equivalent functions with control of error handling: - Execution: err = glthread_once (&name, initfunction); -*/ - - -#ifndef _LOCK_H -#define _LOCK_H - -#include +#ifndef SCM_GLTHREADS_H +#define SCM_GLTHREADS_H + +/* Copyright (C) 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 + * the License, or (at your option) any later version. + * + * This library 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 + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + +/* This file implements Gnulib's glthreads/lock.h interface in terms of + Guile's locking API. This allows Gnulib modules such as 'regex' to + be built with thread-safety support via Guile's locks (see + .) */ + +#include #include -/* ========================================================================= */ - -#if USE_POSIX_THREADS - -/* Use the POSIX threads library. */ - -# include - -# ifdef __cplusplus -extern "C" { -# endif - -# if PTHREAD_IN_USE_DETECTION_HARD - -/* The pthread_in_use() detection needs to be done at runtime. */ -# define pthread_in_use() \ - glthread_in_use () -extern int glthread_in_use (void); - -# endif - -# if USE_POSIX_THREADS_WEAK - -/* Use weak references to the POSIX threads library. */ - -/* Weak references avoid dragging in external libraries if the other parts - of the program don't use them. Here we use them, because we don't want - every program that uses libintl to depend on libpthread. This assumes - that libpthread would not be loaded after libintl; i.e. if libintl is - loaded first, by an executable that does not depend on libpthread, and - then a module is dynamically loaded that depends on libpthread, libintl - will not be multithread-safe. */ - -/* The way to test at runtime whether libpthread is present is to test - whether a function pointer's value, such as &pthread_mutex_init, is - non-NULL. However, some versions of GCC have a bug through which, in - PIC mode, &foo != NULL always evaluates to true if there is a direct - call to foo(...) in the same function. To avoid this, we test the - address of a function in libpthread that we don't use. */ - -# pragma weak pthread_mutex_init -# pragma weak pthread_mutex_lock -# pragma weak pthread_mutex_unlock -# pragma weak pthread_mutex_destroy -# pragma weak pthread_rwlock_init -# pragma weak pthread_rwlock_rdlock -# pragma weak pthread_rwlock_wrlock -# pragma weak pthread_rwlock_unlock -# pragma weak pthread_rwlock_destroy -# pragma weak pthread_once -# pragma weak pthread_cond_init -# pragma weak pthread_cond_wait -# pragma weak pthread_cond_signal -# pragma weak pthread_cond_broadcast -# pragma weak pthread_cond_destroy -# pragma weak pthread_mutexattr_init -# pragma weak pthread_mutexattr_settype -# pragma weak pthread_mutexattr_destroy -# ifndef pthread_self -# pragma weak pthread_self -# endif - -# if !PTHREAD_IN_USE_DETECTION_HARD -# pragma weak pthread_cancel -# define pthread_in_use() (pthread_cancel != NULL) -# endif - -# else - -# if !PTHREAD_IN_USE_DETECTION_HARD -# define pthread_in_use() 1 -# endif - -# endif - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -typedef pthread_mutex_t gl_lock_t; -# define gl_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS pthread_mutex_t NAME; -# define gl_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS pthread_mutex_t NAME = gl_lock_initializer; -# define gl_lock_initializer \ - PTHREAD_MUTEX_INITIALIZER -# define glthread_lock_init(LOCK) \ - (pthread_in_use () ? pthread_mutex_init (LOCK, NULL) : 0) -# define glthread_lock_lock(LOCK) \ - (pthread_in_use () ? pthread_mutex_lock (LOCK) : 0) -# define glthread_lock_unlock(LOCK) \ - (pthread_in_use () ? pthread_mutex_unlock (LOCK) : 0) -# define glthread_lock_destroy(LOCK) \ - (pthread_in_use () ? pthread_mutex_destroy (LOCK) : 0) - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -# if HAVE_PTHREAD_RWLOCK - -# ifdef PTHREAD_RWLOCK_INITIALIZER - -typedef pthread_rwlock_t gl_rwlock_t; -# define gl_rwlock_define(STORAGECLASS, NAME) \ - STORAGECLASS pthread_rwlock_t NAME; -# define gl_rwlock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS pthread_rwlock_t NAME = gl_rwlock_initializer; -# define gl_rwlock_initializer \ - PTHREAD_RWLOCK_INITIALIZER -# define glthread_rwlock_init(LOCK) \ - (pthread_in_use () ? pthread_rwlock_init (LOCK, NULL) : 0) -# define glthread_rwlock_rdlock(LOCK) \ - (pthread_in_use () ? pthread_rwlock_rdlock (LOCK) : 0) -# define glthread_rwlock_wrlock(LOCK) \ - (pthread_in_use () ? pthread_rwlock_wrlock (LOCK) : 0) -# define glthread_rwlock_unlock(LOCK) \ - (pthread_in_use () ? pthread_rwlock_unlock (LOCK) : 0) -# define glthread_rwlock_destroy(LOCK) \ - (pthread_in_use () ? pthread_rwlock_destroy (LOCK) : 0) - -# else - -typedef struct - { - int initialized; - pthread_mutex_t guard; /* protects the initialization */ - pthread_rwlock_t rwlock; /* read-write lock */ - } - gl_rwlock_t; -# define gl_rwlock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_rwlock_t NAME; -# define gl_rwlock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_rwlock_t NAME = gl_rwlock_initializer; -# define gl_rwlock_initializer \ - { 0, PTHREAD_MUTEX_INITIALIZER } -# define glthread_rwlock_init(LOCK) \ - (pthread_in_use () ? glthread_rwlock_init_multithreaded (LOCK) : 0) -# define glthread_rwlock_rdlock(LOCK) \ - (pthread_in_use () ? glthread_rwlock_rdlock_multithreaded (LOCK) : 0) -# define glthread_rwlock_wrlock(LOCK) \ - (pthread_in_use () ? glthread_rwlock_wrlock_multithreaded (LOCK) : 0) -# define glthread_rwlock_unlock(LOCK) \ - (pthread_in_use () ? glthread_rwlock_unlock_multithreaded (LOCK) : 0) -# define glthread_rwlock_destroy(LOCK) \ - (pthread_in_use () ? glthread_rwlock_destroy_multithreaded (LOCK) : 0) -extern int glthread_rwlock_init_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_rdlock_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_wrlock_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_unlock_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_destroy_multithreaded (gl_rwlock_t *lock); - -# endif +#define gl_lock_define(klass, name) \ + klass scm_i_pthread_mutex_t name; -# else - -typedef struct - { - pthread_mutex_t lock; /* protects the remaining fields */ - pthread_cond_t waiting_readers; /* waiting readers */ - pthread_cond_t waiting_writers; /* waiting writers */ - unsigned int waiting_writers_count; /* number of waiting writers */ - int runcount; /* number of readers running, or -1 when a writer runs */ - } - gl_rwlock_t; -# define gl_rwlock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_rwlock_t NAME; -# define gl_rwlock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_rwlock_t NAME = gl_rwlock_initializer; -# define gl_rwlock_initializer \ - { PTHREAD_MUTEX_INITIALIZER, PTHREAD_COND_INITIALIZER, PTHREAD_COND_INITIALIZER, 0, 0 } -# define glthread_rwlock_init(LOCK) \ - (pthread_in_use () ? glthread_rwlock_init_multithreaded (LOCK) : 0) -# define glthread_rwlock_rdlock(LOCK) \ - (pthread_in_use () ? glthread_rwlock_rdlock_multithreaded (LOCK) : 0) -# define glthread_rwlock_wrlock(LOCK) \ - (pthread_in_use () ? glthread_rwlock_wrlock_multithreaded (LOCK) : 0) -# define glthread_rwlock_unlock(LOCK) \ - (pthread_in_use () ? glthread_rwlock_unlock_multithreaded (LOCK) : 0) -# define glthread_rwlock_destroy(LOCK) \ - (pthread_in_use () ? glthread_rwlock_destroy_multithreaded (LOCK) : 0) -extern int glthread_rwlock_init_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_rdlock_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_wrlock_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_unlock_multithreaded (gl_rwlock_t *lock); -extern int glthread_rwlock_destroy_multithreaded (gl_rwlock_t *lock); - -# endif - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -# if HAVE_PTHREAD_MUTEX_RECURSIVE - -# if defined PTHREAD_RECURSIVE_MUTEX_INITIALIZER || defined PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP - -typedef pthread_mutex_t gl_recursive_lock_t; -# define gl_recursive_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS pthread_mutex_t NAME; -# define gl_recursive_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS pthread_mutex_t NAME = gl_recursive_lock_initializer; -# ifdef PTHREAD_RECURSIVE_MUTEX_INITIALIZER -# define gl_recursive_lock_initializer \ - PTHREAD_RECURSIVE_MUTEX_INITIALIZER -# else -# define gl_recursive_lock_initializer \ - PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP -# endif -# define glthread_recursive_lock_init(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_init_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_lock(LOCK) \ - (pthread_in_use () ? pthread_mutex_lock (LOCK) : 0) -# define glthread_recursive_lock_unlock(LOCK) \ - (pthread_in_use () ? pthread_mutex_unlock (LOCK) : 0) -# define glthread_recursive_lock_destroy(LOCK) \ - (pthread_in_use () ? pthread_mutex_destroy (LOCK) : 0) -extern int glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock); - -# else - -typedef struct - { - pthread_mutex_t recmutex; /* recursive mutex */ - pthread_mutex_t guard; /* protects the initialization */ - int initialized; - } - gl_recursive_lock_t; -# define gl_recursive_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME; -# define gl_recursive_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME = gl_recursive_lock_initializer; -# define gl_recursive_lock_initializer \ - { PTHREAD_MUTEX_INITIALIZER, PTHREAD_MUTEX_INITIALIZER, 0 } -# define glthread_recursive_lock_init(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_init_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_lock(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_lock_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_unlock(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_unlock_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_destroy(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_destroy_multithreaded (LOCK) : 0) -extern int glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_lock_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_unlock_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_destroy_multithreaded (gl_recursive_lock_t *lock); - -# endif - -# else - -/* Old versions of POSIX threads on Solaris did not have recursive locks. - We have to implement them ourselves. */ - -typedef struct - { - pthread_mutex_t mutex; - pthread_t owner; - unsigned long depth; - } - gl_recursive_lock_t; -# define gl_recursive_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME; -# define gl_recursive_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME = gl_recursive_lock_initializer; -# define gl_recursive_lock_initializer \ - { PTHREAD_MUTEX_INITIALIZER, (pthread_t) 0, 0 } -# define glthread_recursive_lock_init(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_init_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_lock(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_lock_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_unlock(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_unlock_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_destroy(LOCK) \ - (pthread_in_use () ? glthread_recursive_lock_destroy_multithreaded (LOCK) : 0) -extern int glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_lock_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_unlock_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_destroy_multithreaded (gl_recursive_lock_t *lock); - -# endif - -/* -------------------------- gl_once_t datatype -------------------------- */ - -typedef pthread_once_t gl_once_t; -# define gl_once_define(STORAGECLASS, NAME) \ - STORAGECLASS pthread_once_t NAME = PTHREAD_ONCE_INIT; -# define glthread_once(ONCE_CONTROL, INITFUNCTION) \ - (pthread_in_use () \ - ? pthread_once (ONCE_CONTROL, INITFUNCTION) \ - : (glthread_once_singlethreaded (ONCE_CONTROL) ? (INITFUNCTION (), 0) : 0)) -extern int glthread_once_singlethreaded (pthread_once_t *once_control); - -# ifdef __cplusplus -} -# endif +#define glthread_lock_init(lock) scm_i_pthread_mutex_init ((lock), NULL) +#define glthread_lock_destroy scm_i_pthread_mutex_destroy +#define glthread_lock_lock scm_i_pthread_mutex_lock +#define glthread_lock_unlock scm_i_pthread_mutex_unlock #endif - -/* ========================================================================= */ - -#if USE_PTH_THREADS - -/* Use the GNU Pth threads library. */ - -# include - -# ifdef __cplusplus -extern "C" { -# endif - -# if USE_PTH_THREADS_WEAK - -/* Use weak references to the GNU Pth threads library. */ - -# pragma weak pth_mutex_init -# pragma weak pth_mutex_acquire -# pragma weak pth_mutex_release -# pragma weak pth_rwlock_init -# pragma weak pth_rwlock_acquire -# pragma weak pth_rwlock_release -# pragma weak pth_once - -# pragma weak pth_cancel -# define pth_in_use() (pth_cancel != NULL) - -# else - -# define pth_in_use() 1 - -# endif - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -typedef pth_mutex_t gl_lock_t; -# define gl_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS pth_mutex_t NAME; -# define gl_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS pth_mutex_t NAME = gl_lock_initializer; -# define gl_lock_initializer \ - PTH_MUTEX_INIT -# define glthread_lock_init(LOCK) \ - (pth_in_use () && !pth_mutex_init (LOCK) ? errno : 0) -# define glthread_lock_lock(LOCK) \ - (pth_in_use () && !pth_mutex_acquire (LOCK, 0, NULL) ? errno : 0) -# define glthread_lock_unlock(LOCK) \ - (pth_in_use () && !pth_mutex_release (LOCK) ? errno : 0) -# define glthread_lock_destroy(LOCK) \ - ((void)(LOCK), 0) - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -typedef pth_rwlock_t gl_rwlock_t; -# define gl_rwlock_define(STORAGECLASS, NAME) \ - STORAGECLASS pth_rwlock_t NAME; -# define gl_rwlock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS pth_rwlock_t NAME = gl_rwlock_initializer; -# define gl_rwlock_initializer \ - PTH_RWLOCK_INIT -# define glthread_rwlock_init(LOCK) \ - (pth_in_use () && !pth_rwlock_init (LOCK) ? errno : 0) -# define glthread_rwlock_rdlock(LOCK) \ - (pth_in_use () && !pth_rwlock_acquire (LOCK, PTH_RWLOCK_RD, 0, NULL) ? errno : 0) -# define glthread_rwlock_wrlock(LOCK) \ - (pth_in_use () && !pth_rwlock_acquire (LOCK, PTH_RWLOCK_RW, 0, NULL) ? errno : 0) -# define glthread_rwlock_unlock(LOCK) \ - (pth_in_use () && !pth_rwlock_release (LOCK) ? errno : 0) -# define glthread_rwlock_destroy(LOCK) \ - ((void)(LOCK), 0) - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -/* In Pth, mutexes are recursive by default. */ -typedef pth_mutex_t gl_recursive_lock_t; -# define gl_recursive_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS pth_mutex_t NAME; -# define gl_recursive_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS pth_mutex_t NAME = gl_recursive_lock_initializer; -# define gl_recursive_lock_initializer \ - PTH_MUTEX_INIT -# define glthread_recursive_lock_init(LOCK) \ - (pth_in_use () && !pth_mutex_init (LOCK) ? errno : 0) -# define glthread_recursive_lock_lock(LOCK) \ - (pth_in_use () && !pth_mutex_acquire (LOCK, 0, NULL) ? errno : 0) -# define glthread_recursive_lock_unlock(LOCK) \ - (pth_in_use () && !pth_mutex_release (LOCK) ? errno : 0) -# define glthread_recursive_lock_destroy(LOCK) \ - ((void)(LOCK), 0) - -/* -------------------------- gl_once_t datatype -------------------------- */ - -typedef pth_once_t gl_once_t; -# define gl_once_define(STORAGECLASS, NAME) \ - STORAGECLASS pth_once_t NAME = PTH_ONCE_INIT; -# define glthread_once(ONCE_CONTROL, INITFUNCTION) \ - (pth_in_use () \ - ? glthread_once_multithreaded (ONCE_CONTROL, INITFUNCTION) \ - : (glthread_once_singlethreaded (ONCE_CONTROL) ? (INITFUNCTION (), 0) : 0)) -extern int glthread_once_multithreaded (pth_once_t *once_control, void (*initfunction) (void)); -extern int glthread_once_singlethreaded (pth_once_t *once_control); - -# ifdef __cplusplus -} -# endif - -#endif - -/* ========================================================================= */ - -#if USE_SOLARIS_THREADS - -/* Use the old Solaris threads library. */ - -# include -# include - -# ifdef __cplusplus -extern "C" { -# endif - -# if USE_SOLARIS_THREADS_WEAK - -/* Use weak references to the old Solaris threads library. */ - -# pragma weak mutex_init -# pragma weak mutex_lock -# pragma weak mutex_unlock -# pragma weak mutex_destroy -# pragma weak rwlock_init -# pragma weak rw_rdlock -# pragma weak rw_wrlock -# pragma weak rw_unlock -# pragma weak rwlock_destroy -# pragma weak thr_self - -# pragma weak thr_suspend -# define thread_in_use() (thr_suspend != NULL) - -# else - -# define thread_in_use() 1 - -# endif - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -typedef mutex_t gl_lock_t; -# define gl_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS mutex_t NAME; -# define gl_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS mutex_t NAME = gl_lock_initializer; -# define gl_lock_initializer \ - DEFAULTMUTEX -# define glthread_lock_init(LOCK) \ - (thread_in_use () ? mutex_init (LOCK, USYNC_THREAD, NULL) : 0) -# define glthread_lock_lock(LOCK) \ - (thread_in_use () ? mutex_lock (LOCK) : 0) -# define glthread_lock_unlock(LOCK) \ - (thread_in_use () ? mutex_unlock (LOCK) : 0) -# define glthread_lock_destroy(LOCK) \ - (thread_in_use () ? mutex_destroy (LOCK) : 0) - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -typedef rwlock_t gl_rwlock_t; -# define gl_rwlock_define(STORAGECLASS, NAME) \ - STORAGECLASS rwlock_t NAME; -# define gl_rwlock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS rwlock_t NAME = gl_rwlock_initializer; -# define gl_rwlock_initializer \ - DEFAULTRWLOCK -# define glthread_rwlock_init(LOCK) \ - (thread_in_use () ? rwlock_init (LOCK, USYNC_THREAD, NULL) : 0) -# define glthread_rwlock_rdlock(LOCK) \ - (thread_in_use () ? rw_rdlock (LOCK) : 0) -# define glthread_rwlock_wrlock(LOCK) \ - (thread_in_use () ? rw_wrlock (LOCK) : 0) -# define glthread_rwlock_unlock(LOCK) \ - (thread_in_use () ? rw_unlock (LOCK) : 0) -# define glthread_rwlock_destroy(LOCK) \ - (thread_in_use () ? rwlock_destroy (LOCK) : 0) - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -/* Old Solaris threads did not have recursive locks. - We have to implement them ourselves. */ - -typedef struct - { - mutex_t mutex; - thread_t owner; - unsigned long depth; - } - gl_recursive_lock_t; -# define gl_recursive_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME; -# define gl_recursive_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME = gl_recursive_lock_initializer; -# define gl_recursive_lock_initializer \ - { DEFAULTMUTEX, (thread_t) 0, 0 } -# define glthread_recursive_lock_init(LOCK) \ - (thread_in_use () ? glthread_recursive_lock_init_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_lock(LOCK) \ - (thread_in_use () ? glthread_recursive_lock_lock_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_unlock(LOCK) \ - (thread_in_use () ? glthread_recursive_lock_unlock_multithreaded (LOCK) : 0) -# define glthread_recursive_lock_destroy(LOCK) \ - (thread_in_use () ? glthread_recursive_lock_destroy_multithreaded (LOCK) : 0) -extern int glthread_recursive_lock_init_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_lock_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_unlock_multithreaded (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_destroy_multithreaded (gl_recursive_lock_t *lock); - -/* -------------------------- gl_once_t datatype -------------------------- */ - -typedef struct - { - volatile int inited; - mutex_t mutex; - } - gl_once_t; -# define gl_once_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_once_t NAME = { 0, DEFAULTMUTEX }; -# define glthread_once(ONCE_CONTROL, INITFUNCTION) \ - (thread_in_use () \ - ? glthread_once_multithreaded (ONCE_CONTROL, INITFUNCTION) \ - : (glthread_once_singlethreaded (ONCE_CONTROL) ? (INITFUNCTION (), 0) : 0)) -extern int glthread_once_multithreaded (gl_once_t *once_control, void (*initfunction) (void)); -extern int glthread_once_singlethreaded (gl_once_t *once_control); - -# ifdef __cplusplus -} -# endif - -#endif - -/* ========================================================================= */ - -#if USE_WINDOWS_THREADS - -# define WIN32_LEAN_AND_MEAN /* avoid including junk */ -# include - -# ifdef __cplusplus -extern "C" { -# endif - -/* We can use CRITICAL_SECTION directly, rather than the native Windows Event, - Mutex, Semaphore types, because - - we need only to synchronize inside a single process (address space), - not inter-process locking, - - we don't need to support trylock operations. (TryEnterCriticalSection - does not work on Windows 95/98/ME. Packages that need trylock usually - define their own mutex type.) */ - -/* There is no way to statically initialize a CRITICAL_SECTION. It needs - to be done lazily, once only. For this we need spinlocks. */ - -typedef struct { volatile int done; volatile long started; } gl_spinlock_t; - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -typedef struct - { - gl_spinlock_t guard; /* protects the initialization */ - CRITICAL_SECTION lock; - } - gl_lock_t; -# define gl_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_lock_t NAME; -# define gl_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_lock_t NAME = gl_lock_initializer; -# define gl_lock_initializer \ - { { 0, -1 } } -# define glthread_lock_init(LOCK) \ - (glthread_lock_init_func (LOCK), 0) -# define glthread_lock_lock(LOCK) \ - glthread_lock_lock_func (LOCK) -# define glthread_lock_unlock(LOCK) \ - glthread_lock_unlock_func (LOCK) -# define glthread_lock_destroy(LOCK) \ - glthread_lock_destroy_func (LOCK) -extern void glthread_lock_init_func (gl_lock_t *lock); -extern int glthread_lock_lock_func (gl_lock_t *lock); -extern int glthread_lock_unlock_func (gl_lock_t *lock); -extern int glthread_lock_destroy_func (gl_lock_t *lock); - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -/* It is impossible to implement read-write locks using plain locks, without - introducing an extra thread dedicated to managing read-write locks. - Therefore here we need to use the low-level Event type. */ - -typedef struct - { - HANDLE *array; /* array of waiting threads, each represented by an event */ - unsigned int count; /* number of waiting threads */ - unsigned int alloc; /* length of allocated array */ - unsigned int offset; /* index of first waiting thread in array */ - } - gl_carray_waitqueue_t; -typedef struct - { - gl_spinlock_t guard; /* protects the initialization */ - CRITICAL_SECTION lock; /* protects the remaining fields */ - gl_carray_waitqueue_t waiting_readers; /* waiting readers */ - gl_carray_waitqueue_t waiting_writers; /* waiting writers */ - int runcount; /* number of readers running, or -1 when a writer runs */ - } - gl_rwlock_t; -# define gl_rwlock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_rwlock_t NAME; -# define gl_rwlock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_rwlock_t NAME = gl_rwlock_initializer; -# define gl_rwlock_initializer \ - { { 0, -1 } } -# define glthread_rwlock_init(LOCK) \ - (glthread_rwlock_init_func (LOCK), 0) -# define glthread_rwlock_rdlock(LOCK) \ - glthread_rwlock_rdlock_func (LOCK) -# define glthread_rwlock_wrlock(LOCK) \ - glthread_rwlock_wrlock_func (LOCK) -# define glthread_rwlock_unlock(LOCK) \ - glthread_rwlock_unlock_func (LOCK) -# define glthread_rwlock_destroy(LOCK) \ - glthread_rwlock_destroy_func (LOCK) -extern void glthread_rwlock_init_func (gl_rwlock_t *lock); -extern int glthread_rwlock_rdlock_func (gl_rwlock_t *lock); -extern int glthread_rwlock_wrlock_func (gl_rwlock_t *lock); -extern int glthread_rwlock_unlock_func (gl_rwlock_t *lock); -extern int glthread_rwlock_destroy_func (gl_rwlock_t *lock); - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -/* The native Windows documentation says that CRITICAL_SECTION already - implements a recursive lock. But we need not rely on it: It's easy to - implement a recursive lock without this assumption. */ - -typedef struct - { - gl_spinlock_t guard; /* protects the initialization */ - DWORD owner; - unsigned long depth; - CRITICAL_SECTION lock; - } - gl_recursive_lock_t; -# define gl_recursive_lock_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME; -# define gl_recursive_lock_define_initialized(STORAGECLASS, NAME) \ - STORAGECLASS gl_recursive_lock_t NAME = gl_recursive_lock_initializer; -# define gl_recursive_lock_initializer \ - { { 0, -1 }, 0, 0 } -# define glthread_recursive_lock_init(LOCK) \ - (glthread_recursive_lock_init_func (LOCK), 0) -# define glthread_recursive_lock_lock(LOCK) \ - glthread_recursive_lock_lock_func (LOCK) -# define glthread_recursive_lock_unlock(LOCK) \ - glthread_recursive_lock_unlock_func (LOCK) -# define glthread_recursive_lock_destroy(LOCK) \ - glthread_recursive_lock_destroy_func (LOCK) -extern void glthread_recursive_lock_init_func (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_lock_func (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_unlock_func (gl_recursive_lock_t *lock); -extern int glthread_recursive_lock_destroy_func (gl_recursive_lock_t *lock); - -/* -------------------------- gl_once_t datatype -------------------------- */ - -typedef struct - { - volatile int inited; - volatile long started; - CRITICAL_SECTION lock; - } - gl_once_t; -# define gl_once_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_once_t NAME = { -1, -1 }; -# define glthread_once(ONCE_CONTROL, INITFUNCTION) \ - (glthread_once_func (ONCE_CONTROL, INITFUNCTION), 0) -extern void glthread_once_func (gl_once_t *once_control, void (*initfunction) (void)); - -# ifdef __cplusplus -} -# endif - -#endif - -/* ========================================================================= */ - -#if !(USE_POSIX_THREADS || USE_PTH_THREADS || USE_SOLARIS_THREADS || USE_WINDOWS_THREADS) - -/* Provide dummy implementation if threads are not supported. */ - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -typedef int gl_lock_t; -# define gl_lock_define(STORAGECLASS, NAME) -# define gl_lock_define_initialized(STORAGECLASS, NAME) -# define glthread_lock_init(NAME) 0 -# define glthread_lock_lock(NAME) 0 -# define glthread_lock_unlock(NAME) 0 -# define glthread_lock_destroy(NAME) 0 - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -typedef int gl_rwlock_t; -# define gl_rwlock_define(STORAGECLASS, NAME) -# define gl_rwlock_define_initialized(STORAGECLASS, NAME) -# define glthread_rwlock_init(NAME) 0 -# define glthread_rwlock_rdlock(NAME) 0 -# define glthread_rwlock_wrlock(NAME) 0 -# define glthread_rwlock_unlock(NAME) 0 -# define glthread_rwlock_destroy(NAME) 0 - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -typedef int gl_recursive_lock_t; -# define gl_recursive_lock_define(STORAGECLASS, NAME) -# define gl_recursive_lock_define_initialized(STORAGECLASS, NAME) -# define glthread_recursive_lock_init(NAME) 0 -# define glthread_recursive_lock_lock(NAME) 0 -# define glthread_recursive_lock_unlock(NAME) 0 -# define glthread_recursive_lock_destroy(NAME) 0 - -/* -------------------------- gl_once_t datatype -------------------------- */ - -typedef int gl_once_t; -# define gl_once_define(STORAGECLASS, NAME) \ - STORAGECLASS gl_once_t NAME = 0; -# define glthread_once(ONCE_CONTROL, INITFUNCTION) \ - (*(ONCE_CONTROL) == 0 ? (*(ONCE_CONTROL) = ~ 0, INITFUNCTION (), 0) : 0) - -#endif - -/* ========================================================================= */ - -/* Macros with built-in error handling. */ - -/* -------------------------- gl_lock_t datatype -------------------------- */ - -#define gl_lock_init(NAME) \ - do \ - { \ - if (glthread_lock_init (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_lock_lock(NAME) \ - do \ - { \ - if (glthread_lock_lock (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_lock_unlock(NAME) \ - do \ - { \ - if (glthread_lock_unlock (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_lock_destroy(NAME) \ - do \ - { \ - if (glthread_lock_destroy (&NAME)) \ - abort (); \ - } \ - while (0) - -/* ------------------------- gl_rwlock_t datatype ------------------------- */ - -#define gl_rwlock_init(NAME) \ - do \ - { \ - if (glthread_rwlock_init (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_rwlock_rdlock(NAME) \ - do \ - { \ - if (glthread_rwlock_rdlock (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_rwlock_wrlock(NAME) \ - do \ - { \ - if (glthread_rwlock_wrlock (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_rwlock_unlock(NAME) \ - do \ - { \ - if (glthread_rwlock_unlock (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_rwlock_destroy(NAME) \ - do \ - { \ - if (glthread_rwlock_destroy (&NAME)) \ - abort (); \ - } \ - while (0) - -/* --------------------- gl_recursive_lock_t datatype --------------------- */ - -#define gl_recursive_lock_init(NAME) \ - do \ - { \ - if (glthread_recursive_lock_init (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_recursive_lock_lock(NAME) \ - do \ - { \ - if (glthread_recursive_lock_lock (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_recursive_lock_unlock(NAME) \ - do \ - { \ - if (glthread_recursive_lock_unlock (&NAME)) \ - abort (); \ - } \ - while (0) -#define gl_recursive_lock_destroy(NAME) \ - do \ - { \ - if (glthread_recursive_lock_destroy (&NAME)) \ - abort (); \ - } \ - while (0) - -/* -------------------------- gl_once_t datatype -------------------------- */ - -#define gl_once(NAME, INITFUNCTION) \ - do \ - { \ - if (glthread_once (&NAME, INITFUNCTION)) \ - abort (); \ - } \ - while (0) - -/* ========================================================================= */ - -#endif /* _LOCK_H */ diff --git a/lib/glthread/threadlib.c b/lib/glthread/threadlib.c deleted file mode 100644 index 37a5762d8..000000000 --- a/lib/glthread/threadlib.c +++ /dev/null @@ -1,73 +0,0 @@ -/* Multithreading primitives. - Copyright (C) 2005-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 published by - the Free Software Foundation; either version 2, 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 Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program; if not, see . */ - -/* Written by Bruno Haible , 2005. */ - -#include - -/* ========================================================================= */ - -#if USE_POSIX_THREADS - -/* Use the POSIX threads library. */ - -# include -# include - -# if PTHREAD_IN_USE_DETECTION_HARD - -/* The function to be executed by a dummy thread. */ -static void * -dummy_thread_func (void *arg) -{ - return arg; -} - -int -glthread_in_use (void) -{ - static int tested; - static int result; /* 1: linked with -lpthread, 0: only with libc */ - - if (!tested) - { - pthread_t thread; - - if (pthread_create (&thread, NULL, dummy_thread_func, NULL) != 0) - /* Thread creation failed. */ - result = 0; - else - { - /* Thread creation works. */ - void *retval; - if (pthread_join (thread, &retval) != 0) - abort (); - result = 1; - } - tested = 1; - } - return result; -} - -# endif - -#endif - -/* ========================================================================= */ - -/* This declaration is solely to ensure that after preprocessing - this file is never empty. */ -typedef int dummy; diff --git a/lib/unistd.in.h b/lib/unistd.in.h index 988090814..842025024 100644 --- a/lib/unistd.in.h +++ b/lib/unistd.in.h @@ -21,9 +21,23 @@ #endif @PRAGMA_COLUMNS@ +#ifdef _GL_INCLUDING_UNISTD_H +/* Special invocation convention: + - On Mac OS X 10.3.9 we have a sequence of nested includes + -> -> -> + In this situation, the functions are not yet declared, therefore we cannot + provide the C++ aliases. */ + +#@INCLUDE_NEXT@ @NEXT_UNISTD_H@ + +#else +/* Normal invocation convention. */ + /* The include_next requires a split double-inclusion guard. */ #if @HAVE_UNISTD_H@ +# define _GL_INCLUDING_UNISTD_H # @INCLUDE_NEXT@ @NEXT_UNISTD_H@ +# undef _GL_INCLUDING_UNISTD_H #endif /* Get all possible declarations of gethostname(). */ @@ -1539,4 +1553,5 @@ _GL_CXXALIASWARN (write); _GL_INLINE_HEADER_END #endif /* _@GUARD_PREFIX@_UNISTD_H */ +#endif /* _GL_INCLUDING_UNISTD_H */ #endif /* _@GUARD_PREFIX@_UNISTD_H */ diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index fc7391cda..9e095da7c 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -27,7 +27,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar +# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) @@ -126,7 +126,7 @@ gl_MODULES([ warnings wchar ]) -gl_AVOID([]) +gl_AVOID([lock]) gl_SOURCE_BASE([lib]) gl_M4_BASE([m4]) gl_PO_BASE([]) diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4 index 3b61b239b..20ce40e74 100644 --- a/m4/gnulib-common.m4 +++ b/m4/gnulib-common.m4 @@ -379,3 +379,59 @@ AC_DEFUN([gl_CACHE_VAL_SILENT], # AS_VAR_COPY was added in autoconf 2.63b m4_define_default([AS_VAR_COPY], [AS_LITERAL_IF([$1[]$2], [$1=$$2], [eval $1=\$$2])]) + +# AC_PROG_SED was added in autoconf 2.59b +m4_ifndef([AC_PROG_SED], +[AC_DEFUN([AC_PROG_SED], +[AC_CACHE_CHECK([for a sed that does not truncate output], ac_cv_path_SED, + [dnl ac_script should not contain more than 99 commands (for HP-UX sed), + dnl but more than about 7000 bytes, to catch a limit in Solaris 8 /usr/ucb/sed. + ac_script=s/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb/ + for ac_i in 1 2 3 4 5 6 7; do + ac_script="$ac_script$as_nl$ac_script" + done + echo "$ac_script" 2>/dev/null | sed 99q >conftest.sed + AS_UNSET([ac_script]) + if test -z "$SED"; then + ac_path_SED_found=false + _AS_PATH_WALK([], [ + for ac_prog in sed gsed; do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_SED="$as_dir/$ac_prog$ac_exec_ext" + AS_EXECUTABLE_P(["$ac_path_SED"]) || continue + case `"$ac_path_SED" --version 2>&1` in + *GNU*) ac_cv_path_SED=$ac_path_SED ac_path_SED_found=:;; + *) + ac_count=0 + _AS_ECHO_N([0123456789]) >conftest.in + while : + do + cat conftest.in conftest.in >conftest.tmp + mv conftest.tmp conftest.in + cp conftest.in conftest.nl + echo >> conftest.nl + "$ac_path_SED" -f conftest.sed conftest.out 2>/dev/null || break + diff conftest.out conftest.nl >/dev/null 2>&1 || break + ac_count=`expr $ac_count + 1` + if test $ac_count -gt ${ac_path_SED_max-0}; then + # Best so far, but keep looking for better + ac_cv_path_SED=$ac_path_SED + ac_path_SED_max=$ac_count + fi + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; + esac + $ac_path_SED_found && break 3 + done + done]) + if test -z "$ac_cv_path_SED"; then + AC_ERROR([no acceptable sed could be found in \$PATH]) + fi + else + ac_cv_path_SED=$SED + fi + SED="$ac_cv_path_SED" + AC_SUBST([SED])dnl + rm -f conftest.sed +])])]) diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index b333d6aed..429fee422 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -133,7 +133,6 @@ AC_DEFUN([gl_EARLY], # Code from module localcharset: # Code from module locale: # Code from module localeconv: - # Code from module lock: # Code from module log: # Code from module log1p: # Code from module lstat: @@ -219,8 +218,6 @@ AC_DEFUN([gl_EARLY], # Code from module sys_types: # Code from module sys_uio: # Code from module tempname: - # Code from module threadlib: - gl_THREADLIB_EARLY # Code from module time: # Code from module time_r: # Code from module times: @@ -529,8 +526,6 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_LOCALECONV fi gl_LOCALE_MODULE_INDICATOR([localeconv]) - gl_LOCK - gl_MODULE_INDICATOR([lock]) AC_REQUIRE([gl_FUNC_LOG]) if test $REPLACE_LOG = 1; then AC_LIBOBJ([log]) @@ -549,6 +544,7 @@ AC_SUBST([LTALLOCA]) gl_SYS_STAT_MODULE_INDICATOR([lstat]) AC_CONFIG_COMMANDS_PRE([m4_ifdef([AH_HEADER], [AC_SUBST([CONFIG_INCLUDE], m4_defn([AH_HEADER]))])]) + AC_REQUIRE([AC_PROG_SED]) gl_FUNC_MALLOC_GNU if test $REPLACE_MALLOC = 1; then AC_LIBOBJ([malloc]) @@ -800,7 +796,6 @@ AC_SUBST([LTALLOCA]) gl_HEADER_SYS_UIO AC_PROG_MKDIR_P gl_FUNC_GEN_TEMPNAME - gl_THREADLIB gl_HEADER_TIME_H gl_TIME_R if test $HAVE_LOCALTIME_R = 0 || test $REPLACE_LOCALTIME_R = 1; then @@ -1054,9 +1049,6 @@ AC_DEFUN([gl_FILE_LIST], [ lib/getsockopt.c lib/gettext.h lib/gettimeofday.c - lib/glthread/lock.c - lib/glthread/lock.h - lib/glthread/threadlib.c lib/iconv.c lib/iconv.in.h lib/iconv_close.c @@ -1294,7 +1286,6 @@ AC_DEFUN([gl_FILE_LIST], [ m4/locale-zh.m4 m4/locale_h.m4 m4/localeconv.m4 - m4/lock.m4 m4/log.m4 m4/log1p.m4 m4/longlong.m4 @@ -1372,7 +1363,6 @@ AC_DEFUN([gl_FILE_LIST], [ m4/sys_types_h.m4 m4/sys_uio_h.m4 m4/tempname.m4 - m4/threadlib.m4 m4/time_h.m4 m4/time_r.m4 m4/times.m4 diff --git a/m4/lock.m4 b/m4/lock.m4 deleted file mode 100644 index 73a3c54ce..000000000 --- a/m4/lock.m4 +++ /dev/null @@ -1,42 +0,0 @@ -# lock.m4 serial 13 (gettext-0.18.2) -dnl Copyright (C) 2005-2014 Free Software Foundation, Inc. -dnl This file is free software; the Free Software Foundation -dnl gives unlimited permission to copy and/or distribute it, -dnl with or without modifications, as long as this notice is preserved. - -dnl From Bruno Haible. - -AC_DEFUN([gl_LOCK], -[ - AC_REQUIRE([gl_THREADLIB]) - if test "$gl_threads_api" = posix; then - # OSF/1 4.0 and Mac OS X 10.1 lack the pthread_rwlock_t type and the - # pthread_rwlock_* functions. - AC_CHECK_TYPE([pthread_rwlock_t], - [AC_DEFINE([HAVE_PTHREAD_RWLOCK], [1], - [Define if the POSIX multithreading library has read/write locks.])], - [], - [#include ]) - # glibc defines PTHREAD_MUTEX_RECURSIVE as enum, not as a macro. - AC_COMPILE_IFELSE([ - AC_LANG_PROGRAM( - [[#include ]], - [[ -#if __FreeBSD__ == 4 -error "No, in FreeBSD 4.0 recursive mutexes actually don't work." -#elif (defined __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ \ - && __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1070) -error "No, in Mac OS X < 10.7 recursive mutexes actually don't work." -#else -int x = (int)PTHREAD_MUTEX_RECURSIVE; -return !x; -#endif - ]])], - [AC_DEFINE([HAVE_PTHREAD_MUTEX_RECURSIVE], [1], - [Define if the defines PTHREAD_MUTEX_RECURSIVE.])]) - fi - gl_PREREQ_LOCK -]) - -# Prerequisites of lib/glthread/lock.c. -AC_DEFUN([gl_PREREQ_LOCK], [:]) diff --git a/m4/threadlib.m4 b/m4/threadlib.m4 deleted file mode 100644 index a88170261..000000000 --- a/m4/threadlib.m4 +++ /dev/null @@ -1,371 +0,0 @@ -# threadlib.m4 serial 10 (gettext-0.18.2) -dnl Copyright (C) 2005-2014 Free Software Foundation, Inc. -dnl This file is free software; the Free Software Foundation -dnl gives unlimited permission to copy and/or distribute it, -dnl with or without modifications, as long as this notice is preserved. - -dnl From Bruno Haible. - -dnl gl_THREADLIB -dnl ------------ -dnl Tests for a multithreading library to be used. -dnl If the configure.ac contains a definition of the gl_THREADLIB_DEFAULT_NO -dnl (it must be placed before the invocation of gl_THREADLIB_EARLY!), then the -dnl default is 'no', otherwise it is system dependent. In both cases, the user -dnl can change the choice through the options --enable-threads=choice or -dnl --disable-threads. -dnl Defines at most one of the macros USE_POSIX_THREADS, USE_SOLARIS_THREADS, -dnl USE_PTH_THREADS, USE_WINDOWS_THREADS -dnl Sets the variables LIBTHREAD and LTLIBTHREAD to the linker options for use -dnl in a Makefile (LIBTHREAD for use without libtool, LTLIBTHREAD for use with -dnl libtool). -dnl Sets the variables LIBMULTITHREAD and LTLIBMULTITHREAD similarly, for -dnl programs that really need multithread functionality. The difference -dnl between LIBTHREAD and LIBMULTITHREAD is that on platforms supporting weak -dnl symbols, typically LIBTHREAD="" whereas LIBMULTITHREAD="-lpthread". -dnl Adds to CPPFLAGS the flag -D_REENTRANT or -D_THREAD_SAFE if needed for -dnl multithread-safe programs. - -AC_DEFUN([gl_THREADLIB_EARLY], -[ - AC_REQUIRE([gl_THREADLIB_EARLY_BODY]) -]) - -dnl The guts of gl_THREADLIB_EARLY. Needs to be expanded only once. - -AC_DEFUN([gl_THREADLIB_EARLY_BODY], -[ - dnl Ordering constraints: This macro modifies CPPFLAGS in a way that - dnl influences the result of the autoconf tests that test for *_unlocked - dnl declarations, on AIX 5 at least. Therefore it must come early. - AC_BEFORE([$0], [gl_FUNC_GLIBC_UNLOCKED_IO])dnl - AC_BEFORE([$0], [gl_ARGP])dnl - - AC_REQUIRE([AC_CANONICAL_HOST]) - dnl _GNU_SOURCE is needed for pthread_rwlock_t on glibc systems. - dnl AC_USE_SYSTEM_EXTENSIONS was introduced in autoconf 2.60 and obsoletes - dnl AC_GNU_SOURCE. - m4_ifdef([AC_USE_SYSTEM_EXTENSIONS], - [AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])], - [AC_REQUIRE([AC_GNU_SOURCE])]) - dnl Check for multithreading. - m4_ifdef([gl_THREADLIB_DEFAULT_NO], - [m4_divert_text([DEFAULTS], [gl_use_threads_default=no])], - [m4_divert_text([DEFAULTS], [gl_use_threads_default=])]) - AC_ARG_ENABLE([threads], -AC_HELP_STRING([--enable-threads={posix|solaris|pth|windows}], [specify multithreading API])m4_ifdef([gl_THREADLIB_DEFAULT_NO], [], [ -AC_HELP_STRING([--disable-threads], [build without multithread safety])]), - [gl_use_threads=$enableval], - [if test -n "$gl_use_threads_default"; then - gl_use_threads="$gl_use_threads_default" - else -changequote(,)dnl - case "$host_os" in - dnl Disable multithreading by default on OSF/1, because it interferes - dnl with fork()/exec(): When msgexec is linked with -lpthread, its - dnl child process gets an endless segmentation fault inside execvp(). - dnl Disable multithreading by default on Cygwin 1.5.x, because it has - dnl bugs that lead to endless loops or crashes. See - dnl . - osf*) gl_use_threads=no ;; - cygwin*) - case `uname -r` in - 1.[0-5].*) gl_use_threads=no ;; - *) gl_use_threads=yes ;; - esac - ;; - *) gl_use_threads=yes ;; - esac -changequote([,])dnl - fi - ]) - if test "$gl_use_threads" = yes || test "$gl_use_threads" = posix; then - # For using : - case "$host_os" in - osf*) - # On OSF/1, the compiler needs the flag -D_REENTRANT so that it - # groks . cc also understands the flag -pthread, but - # we don't use it because 1. gcc-2.95 doesn't understand -pthread, - # 2. putting a flag into CPPFLAGS that has an effect on the linker - # causes the AC_LINK_IFELSE test below to succeed unexpectedly, - # leading to wrong values of LIBTHREAD and LTLIBTHREAD. - CPPFLAGS="$CPPFLAGS -D_REENTRANT" - ;; - esac - # Some systems optimize for single-threaded programs by default, and - # need special flags to disable these optimizations. For example, the - # definition of 'errno' in . - case "$host_os" in - aix* | freebsd*) CPPFLAGS="$CPPFLAGS -D_THREAD_SAFE" ;; - solaris*) CPPFLAGS="$CPPFLAGS -D_REENTRANT" ;; - esac - fi -]) - -dnl The guts of gl_THREADLIB. Needs to be expanded only once. - -AC_DEFUN([gl_THREADLIB_BODY], -[ - AC_REQUIRE([gl_THREADLIB_EARLY_BODY]) - gl_threads_api=none - LIBTHREAD= - LTLIBTHREAD= - LIBMULTITHREAD= - LTLIBMULTITHREAD= - if test "$gl_use_threads" != no; then - dnl Check whether the compiler and linker support weak declarations. - AC_CACHE_CHECK([whether imported symbols can be declared weak], - [gl_cv_have_weak], - [gl_cv_have_weak=no - dnl First, test whether the compiler accepts it syntactically. - AC_LINK_IFELSE( - [AC_LANG_PROGRAM( - [[extern void xyzzy (); -#pragma weak xyzzy]], - [[xyzzy();]])], - [gl_cv_have_weak=maybe]) - if test $gl_cv_have_weak = maybe; then - dnl Second, test whether it actually works. On Cygwin 1.7.2, with - dnl gcc 4.3, symbols declared weak always evaluate to the address 0. - AC_RUN_IFELSE( - [AC_LANG_SOURCE([[ -#include -#pragma weak fputs -int main () -{ - return (fputs == NULL); -}]])], - [gl_cv_have_weak=yes], - [gl_cv_have_weak=no], - [dnl When cross-compiling, assume that only ELF platforms support - dnl weak symbols. - AC_EGREP_CPP([Extensible Linking Format], - [#ifdef __ELF__ - Extensible Linking Format - #endif - ], - [gl_cv_have_weak="guessing yes"], - [gl_cv_have_weak="guessing no"]) - ]) - fi - ]) - if test "$gl_use_threads" = yes || test "$gl_use_threads" = posix; then - # On OSF/1, the compiler needs the flag -pthread or -D_REENTRANT so that - # it groks . It's added above, in gl_THREADLIB_EARLY_BODY. - AC_CHECK_HEADER([pthread.h], - [gl_have_pthread_h=yes], [gl_have_pthread_h=no]) - if test "$gl_have_pthread_h" = yes; then - # Other possible tests: - # -lpthreads (FSU threads, PCthreads) - # -lgthreads - gl_have_pthread= - # Test whether both pthread_mutex_lock and pthread_mutexattr_init exist - # in libc. IRIX 6.5 has the first one in both libc and libpthread, but - # the second one only in libpthread, and lock.c needs it. - AC_LINK_IFELSE( - [AC_LANG_PROGRAM( - [[#include ]], - [[pthread_mutex_lock((pthread_mutex_t*)0); - pthread_mutexattr_init((pthread_mutexattr_t*)0);]])], - [gl_have_pthread=yes]) - # Test for libpthread by looking for pthread_kill. (Not pthread_self, - # since it is defined as a macro on OSF/1.) - if test -n "$gl_have_pthread"; then - # The program links fine without libpthread. But it may actually - # need to link with libpthread in order to create multiple threads. - AC_CHECK_LIB([pthread], [pthread_kill], - [LIBMULTITHREAD=-lpthread LTLIBMULTITHREAD=-lpthread - # On Solaris and HP-UX, most pthread functions exist also in libc. - # Therefore pthread_in_use() needs to actually try to create a - # thread: pthread_create from libc will fail, whereas - # pthread_create will actually create a thread. - case "$host_os" in - solaris* | hpux*) - AC_DEFINE([PTHREAD_IN_USE_DETECTION_HARD], [1], - [Define if the pthread_in_use() detection is hard.]) - esac - ]) - else - # Some library is needed. Try libpthread and libc_r. - AC_CHECK_LIB([pthread], [pthread_kill], - [gl_have_pthread=yes - LIBTHREAD=-lpthread LTLIBTHREAD=-lpthread - LIBMULTITHREAD=-lpthread LTLIBMULTITHREAD=-lpthread]) - if test -z "$gl_have_pthread"; then - # For FreeBSD 4. - AC_CHECK_LIB([c_r], [pthread_kill], - [gl_have_pthread=yes - LIBTHREAD=-lc_r LTLIBTHREAD=-lc_r - LIBMULTITHREAD=-lc_r LTLIBMULTITHREAD=-lc_r]) - fi - fi - if test -n "$gl_have_pthread"; then - gl_threads_api=posix - AC_DEFINE([USE_POSIX_THREADS], [1], - [Define if the POSIX multithreading library can be used.]) - if test -n "$LIBMULTITHREAD" || test -n "$LTLIBMULTITHREAD"; then - if case "$gl_cv_have_weak" in *yes) true;; *) false;; esac; then - AC_DEFINE([USE_POSIX_THREADS_WEAK], [1], - [Define if references to the POSIX multithreading library should be made weak.]) - LIBTHREAD= - LTLIBTHREAD= - fi - fi - fi - fi - fi - if test -z "$gl_have_pthread"; then - if test "$gl_use_threads" = yes || test "$gl_use_threads" = solaris; then - gl_have_solaristhread= - gl_save_LIBS="$LIBS" - LIBS="$LIBS -lthread" - AC_LINK_IFELSE( - [AC_LANG_PROGRAM( - [[ -#include -#include - ]], - [[thr_self();]])], - [gl_have_solaristhread=yes]) - LIBS="$gl_save_LIBS" - if test -n "$gl_have_solaristhread"; then - gl_threads_api=solaris - LIBTHREAD=-lthread - LTLIBTHREAD=-lthread - LIBMULTITHREAD="$LIBTHREAD" - LTLIBMULTITHREAD="$LTLIBTHREAD" - AC_DEFINE([USE_SOLARIS_THREADS], [1], - [Define if the old Solaris multithreading library can be used.]) - if case "$gl_cv_have_weak" in *yes) true;; *) false;; esac; then - AC_DEFINE([USE_SOLARIS_THREADS_WEAK], [1], - [Define if references to the old Solaris multithreading library should be made weak.]) - LIBTHREAD= - LTLIBTHREAD= - fi - fi - fi - fi - if test "$gl_use_threads" = pth; then - gl_save_CPPFLAGS="$CPPFLAGS" - AC_LIB_LINKFLAGS([pth]) - gl_have_pth= - gl_save_LIBS="$LIBS" - LIBS="$LIBS $LIBPTH" - AC_LINK_IFELSE( - [AC_LANG_PROGRAM([[#include ]], [[pth_self();]])], - [gl_have_pth=yes]) - LIBS="$gl_save_LIBS" - if test -n "$gl_have_pth"; then - gl_threads_api=pth - LIBTHREAD="$LIBPTH" - LTLIBTHREAD="$LTLIBPTH" - LIBMULTITHREAD="$LIBTHREAD" - LTLIBMULTITHREAD="$LTLIBTHREAD" - AC_DEFINE([USE_PTH_THREADS], [1], - [Define if the GNU Pth multithreading library can be used.]) - if test -n "$LIBMULTITHREAD" || test -n "$LTLIBMULTITHREAD"; then - if case "$gl_cv_have_weak" in *yes) true;; *) false;; esac; then - AC_DEFINE([USE_PTH_THREADS_WEAK], [1], - [Define if references to the GNU Pth multithreading library should be made weak.]) - LIBTHREAD= - LTLIBTHREAD= - fi - fi - else - CPPFLAGS="$gl_save_CPPFLAGS" - fi - fi - if test -z "$gl_have_pthread"; then - case "$gl_use_threads" in - yes | windows | win32) # The 'win32' is for backward compatibility. - if { case "$host_os" in - mingw*) true;; - *) false;; - esac - }; then - gl_threads_api=windows - AC_DEFINE([USE_WINDOWS_THREADS], [1], - [Define if the native Windows multithreading API can be used.]) - fi - ;; - esac - fi - fi - AC_MSG_CHECKING([for multithread API to use]) - AC_MSG_RESULT([$gl_threads_api]) - AC_SUBST([LIBTHREAD]) - AC_SUBST([LTLIBTHREAD]) - AC_SUBST([LIBMULTITHREAD]) - AC_SUBST([LTLIBMULTITHREAD]) -]) - -AC_DEFUN([gl_THREADLIB], -[ - AC_REQUIRE([gl_THREADLIB_EARLY]) - AC_REQUIRE([gl_THREADLIB_BODY]) -]) - - -dnl gl_DISABLE_THREADS -dnl ------------------ -dnl Sets the gl_THREADLIB default so that threads are not used by default. -dnl The user can still override it at installation time, by using the -dnl configure option '--enable-threads'. - -AC_DEFUN([gl_DISABLE_THREADS], [ - m4_divert_text([INIT_PREPARE], [gl_use_threads_default=no]) -]) - - -dnl Survey of platforms: -dnl -dnl Platform Available Compiler Supports test-lock -dnl flavours option weak result -dnl --------------- --------- --------- -------- --------- -dnl Linux 2.4/glibc posix -lpthread Y OK -dnl -dnl GNU Hurd/glibc posix -dnl -dnl FreeBSD 5.3 posix -lc_r Y -dnl posix -lkse ? Y -dnl posix -lpthread ? Y -dnl posix -lthr Y -dnl -dnl FreeBSD 5.2 posix -lc_r Y -dnl posix -lkse Y -dnl posix -lthr Y -dnl -dnl FreeBSD 4.0,4.10 posix -lc_r Y OK -dnl -dnl NetBSD 1.6 -- -dnl -dnl OpenBSD 3.4 posix -lpthread Y OK -dnl -dnl Mac OS X 10.[123] posix -lpthread Y OK -dnl -dnl Solaris 7,8,9 posix -lpthread Y Sol 7,8: 0.0; Sol 9: OK -dnl solaris -lthread Y Sol 7,8: 0.0; Sol 9: OK -dnl -dnl HP-UX 11 posix -lpthread N (cc) OK -dnl Y (gcc) -dnl -dnl IRIX 6.5 posix -lpthread Y 0.5 -dnl -dnl AIX 4.3,5.1 posix -lpthread N AIX 4: 0.5; AIX 5: OK -dnl -dnl OSF/1 4.0,5.1 posix -pthread (cc) N OK -dnl -lpthread (gcc) Y -dnl -dnl Cygwin posix -lpthread Y OK -dnl -dnl Any of the above pth -lpth 0.0 -dnl -dnl Mingw windows N OK -dnl -dnl BeOS 5 -- -dnl -dnl The test-lock result shows what happens if in test-lock.c EXPLICIT_YIELD is -dnl turned off: -dnl OK if all three tests terminate OK, -dnl 0.5 if the first test terminates OK but the second one loops endlessly, -dnl 0.0 if the first test already loops endlessly. diff --git a/maint.mk b/maint.mk index d5bb427a2..30f2e8e69 100644 --- a/maint.mk +++ b/maint.mk @@ -76,7 +76,7 @@ _dot_escaped_srcdir = $(subst .,\.,$(srcdir)) ifeq ($(srcdir),.) _prepend_srcdir_prefix = else - _prepend_srcdir_prefix = | sed 's|^|$(srcdir)/|' + _prepend_srcdir_prefix = | $(SED) 's|^|$(srcdir)/|' endif # In order to be able to consistently filter "."-relative names, @@ -85,7 +85,7 @@ endif _sc_excl = \ $(or $(exclude_file_name_regexp--$@),^$$) VC_LIST_EXCEPT = \ - $(VC_LIST) | sed 's|^$(_dot_escaped_srcdir)/||' \ + $(VC_LIST) | $(SED) 's|^$(_dot_escaped_srcdir)/||' \ | if test -f $(srcdir)/.x-$@; then grep -vEf $(srcdir)/.x-$@; \ else grep -Ev -e "$${VC_LIST_EXCEPT_DEFAULT-ChangeLog}"; fi \ | grep -Ev -e '($(VC_LIST_ALWAYS_EXCLUDE_REGEX)|$(_sc_excl))' \ @@ -158,8 +158,8 @@ export LC_ALL = C _cfg_mk := $(wildcard $(srcdir)/cfg.mk) # Collect the names of rules starting with 'sc_'. -syntax-check-rules := $(sort $(shell sed -n 's/^\(sc_[a-zA-Z0-9_-]*\):.*/\1/p' \ - $(srcdir)/$(ME) $(_cfg_mk))) +syntax-check-rules := $(sort $(shell $(SED) -n \ + 's/^\(sc_[a-zA-Z0-9_-]*\):.*/\1/p' $(srcdir)/$(ME) $(_cfg_mk))) .PHONY: $(syntax-check-rules) ifeq ($(shell $(VC_LIST) >/dev/null 2>&1; echo $$?),0) @@ -448,7 +448,7 @@ sc_require_config_h_first: @if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \ fail=0; \ for i in $$($(VC_LIST_EXCEPT) | grep '\.c$$'); do \ - grep '^# *include\>' $$i | sed 1q \ + grep '^# *include\>' $$i | $(SED) 1q \ | grep -E '^# *include $(config_h_header)' > /dev/null \ || { echo $$i; fail=1; }; \ done; \ @@ -468,7 +468,7 @@ sc_prohibit_HAVE_MBRTOWC: # re: a regular expression that matches IFF something provided by $h is used. define _sc_header_without_use dummy=; : so we do not need a semicolon before each use; \ - h_esc=`echo '[<"]'"$$h"'[">]'|sed 's/\./\\\\./g'`; \ + h_esc=`echo '[<"]'"$$h"'[">]'|$(SED) 's/\./\\\\./g'`; \ if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \ files=$$(grep -l '^# *include '"$$h_esc" \ $$($(VC_LIST_EXCEPT) | grep '\.c$$')) && \ @@ -789,7 +789,7 @@ sc_useless_cpp_parens: # #if HAVE_HEADER_H that you remove, be sure that your project explicitly # requires the gnulib module that guarantees the usability of that header. gl_assured_headers_ = \ - cd $(gnulib_dir)/lib && echo *.in.h|sed 's/\.in\.h//g' + cd $(gnulib_dir)/lib && echo *.in.h|$(SED) 's/\.in\.h//g' # Convert the list of names to upper case, and replace each space with "|". az_ = abcdefghijklmnopqrstuvwxyz @@ -840,7 +840,7 @@ define def_sym_regex && perl -lne '$(gl_extract_significant_defines_)' $$f; \ done; \ ) | sort -u \ - | sed 's/^/^ *# *(define|undef) */;s/$$/\\>/' + | $(SED) 's/^/^ *# *(define|undef) */;s/$$/\\>/' endef # Don't define macros that we already get from gnulib header files. @@ -1054,12 +1054,12 @@ sc_const_long_option: $(_sc_search_regexp) NEWS_hash = \ - $$(sed -n '/^\*.* $(PREV_VERSION_REGEXP) ([0-9-]*)/,$$p' \ + $$($(SED) -n '/^\*.* $(PREV_VERSION_REGEXP) ([0-9-]*)/,$$p' \ $(srcdir)/NEWS \ | perl -0777 -pe \ 's/^Copyright.+?Free\sSoftware\sFoundation,\sInc\.\n//ms' \ | md5sum - \ - | sed 's/ .*//') + | $(SED) 's/ .*//') # Ensure that we don't accidentally insert an entry into an old NEWS block. sc_immutable_NEWS: @@ -1097,7 +1097,7 @@ sc_makefile_at_at_check: && { echo '$(ME): use $$(...), not @...@' 1>&2; exit 1; } || : news-check: NEWS - $(AM_V_GEN)if sed -n $(news-check-lines-spec)p $< \ + $(AM_V_GEN)if $(SED) -n $(news-check-lines-spec)p $< \ | grep -E $(news-check-regexp) >/dev/null; then \ :; \ else \ @@ -1146,7 +1146,7 @@ sc_po_check: files="$$files $$file"; \ done; \ grep -E -l '$(_gl_translatable_string_re)' $$files \ - | sed 's|^$(_dot_escaped_srcdir)/||' | sort -u > $@-2; \ + | $(SED) 's|^$(_dot_escaped_srcdir)/||' | sort -u > $@-2; \ diff -u -L $(po_file) -L $(po_file) $@-1 $@-2 \ || { printf '$(ME): '$(fix_po_file_diag) 1>&2; exit 1; }; \ rm -f $@-1 $@-2; \ @@ -1511,7 +1511,7 @@ refresh-gnulib-patches: test -n "$$t" && gl=$$t; \ fi; \ for diff in $$(cd $$gl; git ls-files | grep '\.diff$$'); do \ - b=$$(printf %s "$$diff"|sed 's/\.diff$$//'); \ + b=$$(printf %s "$$diff"|$(SED) 's/\.diff$$//'); \ VERSION_CONTROL=none \ patch "$(gnulib_dir)/$$b" "$$gl/$$diff" || exit 1; \ ( cd $(gnulib_dir) || exit 1; \ @@ -1530,7 +1530,8 @@ refresh-po: wget --no-verbose --directory-prefix $(PODIR) --no-directories --recursive --level 1 --accept .po --accept .po.1 $(POURL) && \ echo 'en@boldquot' > $(PODIR)/LINGUAS && \ echo 'en@quot' >> $(PODIR)/LINGUAS && \ - ls $(PODIR)/*.po | sed 's/\.po//;s,$(PODIR)/,,' | sort >> $(PODIR)/LINGUAS + ls $(PODIR)/*.po | $(SED) 's/\.po//;s,$(PODIR)/,,' | \ + sort >> $(PODIR)/LINGUAS # Running indent once is not idempotent, but running it twice is. INDENT_SOURCES ?= $(C_SOURCES) @@ -1640,18 +1641,18 @@ _gl_tight_scope: $(bin_PROGRAMS) test -f $$f && d= || d=$(srcdir)/; echo $$d$$f; done`; \ ( printf '^%s$$\n' '__.*' $(_gl_TS_unmarked_extern_functions); \ grep -h -A1 '^extern .*[^;]$$' $$src \ - | grep -vE '^(extern |--)' | sed 's/ .*//'; \ + | grep -vE '^(extern |--)' | $(SED) 's/ .*//'; \ perl -lne \ '$(_gl_TS_function_match) and print "^$$1\$$"' $$hdr; \ ) | sort -u > $$t; \ - nm -e $(_gl_TS_obj_files) | sed -n 's/.* T //p'|grep -Ev -f $$t \ + nm -e $(_gl_TS_obj_files)|$(SED) -n 's/.* T //p'|grep -Ev -f $$t \ && { echo the above functions should have static scope >&2; \ exit 1; } || : ; \ ( printf '^%s$$\n' '__.*' $(_gl_TS_unmarked_extern_vars); \ perl -lne '$(_gl_TS_var_match) and print "^$$1\$$"' \ $$hdr $(_gl_TS_other_headers) \ ) | sort -u > $$t; \ - nm -e $(_gl_TS_obj_files) | sed -n 's/.* [BCDGRS] //p' \ + nm -e $(_gl_TS_obj_files) | $(SED) -n 's/.* [BCDGRS] //p' \ | sort -u | grep -Ev -f $$t \ && { echo the above variables should have static scope >&2; \ exit 1; } || : -- cgit v1.2.3 From 3b7601cb34b068a231f6992ad9bbd3c50659efd4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 12 Mar 2014 00:03:03 +0100 Subject: Thank Paul. --- THANKS | 1 + 1 file changed, 1 insertion(+) diff --git a/THANKS b/THANKS index faef9b6a6..d34b951e2 100644 --- a/THANKS +++ b/THANKS @@ -5,6 +5,7 @@ Contributors since the last release: Aleix Conchillo Flaqué Ludovic Courtès Jason Earl + Paul Eggert Brian Gough Volker Grabsch Julian Graham -- cgit v1.2.3 From 19c0bd22a8f5e7cd76cf1435504c8eca342285ff Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 11 Mar 2014 20:12:32 -0400 Subject: Avoid side effects in argument to SCM_I_INUM. * libguile/vm-i-system.c (halt): Avoid side effects in argument to SCM_I_INUM. --- libguile/vm-i-system.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index e54a99ba6..5057fb02b 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -32,8 +32,11 @@ VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0) VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0) { SCM ret; + SCM nvalues_scm; - nvalues = SCM_I_INUM (*sp--); + nvalues_scm = *sp--; /* SCM_I_INUM may evaluate its argument + more than once. */ + nvalues = SCM_I_INUM (nvalues_scm); NULLSTACK (1); if (nvalues == 1) -- cgit v1.2.3 From 5fbf0e0f99431f54da032bda47d8125f9d34b4b1 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 11 Mar 2014 20:15:27 -0400 Subject: Avoid signed overflow in random.c. * libguile/random.c (scm_i_mask32): Avoid signed overflow from shifting an unsigned char (promoted to signed int) 24 bits to the left. --- libguile/random.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/random.c b/libguile/random.c index 18737aa5a..4051d1f34 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -255,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 -- cgit v1.2.3 From 03cce0ce5fba210e4abd8fa5dfddb04022a27e75 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 11 Mar 2014 20:19:17 -0400 Subject: Avoid undefined behavior regarding signed integers and left shifts. * libguile/numbers.c (scm_logbit_p): If the requested bit is the sign bit (or above), check the sign portably. Otherwise, ensure that we're testing the bit in a two's complement representation. (left_shift_exact_integer): Avoid left-shifting negative integers. * libguile/vm-i-scheme.c (ash): Avoid left-shifting negative integers. --- libguile/numbers.c | 18 ++++++++++++------ libguile/vm-i-scheme.c | 7 +++++-- 2 files changed, 17 insertions(+), 8 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 51e813ac9..c197eee8e 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. + * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, + * 2014 Free Software Foundation, Inc. * * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * and Bellcore. See scm_divide. @@ -4680,9 +4680,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)) { @@ -4992,7 +4998,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/vm-i-scheme.c b/libguile/vm-i-scheme.c index dd2150ddc..587aa9566 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -1,4 +1,5 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 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 @@ -505,7 +506,9 @@ VM_DEFINE_FUNCTION (159, ash, "ash", 2) && ((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 */ -- cgit v1.2.3 From 9fcee9da3f28b4b190d6976aeea72ab3c9f62bb2 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 11 Mar 2014 20:31:38 -0400 Subject: Use 'offsetof' to avoid undefined behavior. * libguile/socket.c (SUN_LEN): Use 'offsetof'. --- libguile/socket.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/socket.c b/libguile/socket.c index c0faae1aa..5b17a741a 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -64,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 -- cgit v1.2.3 From 7f8ad91b994d4922efdd7f9f89400b1ebddeed8f Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 11 Mar 2014 20:34:28 -0400 Subject: SRFI-60: Reimplement 'rotate-bit-field' on inums to be more portable. * libguile/srfi-60.c (scm_srfi60_rotate_bit_field): Avoid division by zero in the (start == end) case. Rewrite inum case to work with unsigned integers in two's complement format. * test-suite/tests/srfi-60.test ("rotate-bit-field"): Add more tests. --- libguile/srfi-60.c | 60 ++++++++++++++++++++--------- test-suite/tests/srfi-60.test | 89 +++++++++++++++++++++++++++++++++---------- 2 files changed, 109 insertions(+), 40 deletions(-) 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/test-suite/tests/srfi-60.test b/test-suite/tests/srfi-60.test index 940934f3e..1c91943a4 100644 --- a/test-suite/tests/srfi-60.test +++ b/test-suite/tests/srfi-60.test @@ -268,27 +268,74 @@ ;; (with-test-prefix "rotate-bit-field" - (pass-if (eqv? #b110 (rotate-bit-field #b110 1 1 2))) - (pass-if (eqv? #b1010 (rotate-bit-field #b110 1 2 4))) - (pass-if (eqv? #b1011 (rotate-bit-field #b0111 -1 1 4))) - - (pass-if (eqv? #b0 (rotate-bit-field #b0 128 0 256))) - (pass-if (eqv? #b1 (rotate-bit-field #b1 128 1 256))) - (pass-if - (eqv? #x100000000000000000000000000000000 - (rotate-bit-field #x100000000000000000000000000000000 128 0 64))) - (pass-if - (eqv? #x100000000000000000000000000000008 - (rotate-bit-field #x100000000000000000000000000000001 3 0 64))) - (pass-if - (eqv? #x100000000000000002000000000000000 - (rotate-bit-field #x100000000000000000000000000000001 -3 0 64))) - - (pass-if (eqv? #b110 (rotate-bit-field #b110 0 0 10))) - (pass-if (eqv? #b110 (rotate-bit-field #b110 0 0 256))) - - (pass-if "bignum becomes inum" - (eqv? 1 (rotate-bit-field #x100000000000000000000000000000000 1 0 129)))) + (define-syntax-rule (check expected x count start end) + (begin + (pass-if-equal expected (rotate-bit-field x count start end)) + (pass-if-equal (lognot expected) + (rotate-bit-field (lognot x) count start end)))) + + (check #b110 #b110 1 1 2) + (check #b1010 #b110 1 2 4) + (check #b1011 #b0111 -1 1 4) + + (check #b0 #b0 128 0 256) + (check #b1 #b1 128 1 256) + (check #x100000000000000000000000000000000 + #x100000000000000000000000000000000 128 0 64) + (check #x100000000000000000000000000000008 + #x100000000000000000000000000000001 3 0 64) + (check #x100000000000000002000000000000000 + #x100000000000000000000000000000001 -3 0 64) + + (check #b110 #b110 0 0 10) + (check #b110 #b110 0 0 256) + + (check #b110 #b110 1 1 1) + + (check #b10111010001100111101110010101 + #b11010001100111101110001110101 -26 5 28) + (check #b11000110011110111000111011001 + #b11010001100111101110001110101 28 2 28) + + (check #b01111010001100111101110010101 + #b11010001100111101110001110101 -3 5 29) + (check #b10100011001111011100011101101 + #b11010001100111101110001110101 28 2 29) + + (check #b110110100011001111011100010101 + #b011010001100111101110001110101 48 5 30) + (check #b110100011001111011100011101001 + #b011010001100111101110001110101 85 2 30) + (check #b011010001100111101110001110101 + #b110100011001111011100011101001 83 2 30) + + (check + #b1101100110101001110000111110011010000111011101011101110111011 + #b1100110101001110000111110011010000111011101011101110110111011 -3 5 60) + (check + #b1011010100111000011111001101000011101110101110111011011101110 + #b1100110101001110000111110011010000111011101011101110110111011 62 0 60) + + (check + #b1011100110101001110000111110011010000111011101011101110111011 + #b1100110101001110000111110011010000111011101011101110110111011 53 5 61) + (check + #b1001101010011100001111100110100001110111010111011101101110111 + #b1100110101001110000111110011010000111011101011101110110111011 62 0 61) + + (check + #b11011001101010011100001111100110100001110111010111011100111011 + #b01100110101001110000111110011010000111011101011101110110111011 53 7 62) + (check + #b11011001101010011100001111100110100001110111010111011100111011 + #b01100110101001110000111110011010000111011101011101110110111011 -2 7 62) + (check + #b01100110101001110000111110011010000111011101011101110110111011 + #b11011001101010011100001111100110100001110111010111011100111011 2 7 62) + + (pass-if-equal "bignum becomes inum" + 1 + (rotate-bit-field #x100000000000000000000000000000000 1 0 129))) ;; ;; reverse-bit-field -- cgit v1.2.3 From e293c94c65d49171c54bb1893c355e36c66806b8 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 11 Mar 2014 21:27:21 -0400 Subject: SCM_SRS: Improve fallback implemention to avoid unspecified behavior. * libguile/numbers.h (SCM_SRS): Rewrite preprocessor test to avoid left-shifting negative integers, and to test more comprehensively for the behavior we need. Rewrite fallback implementation to avoid unspecified behavior. --- libguile/numbers.h | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/libguile/numbers.h b/libguile/numbers.h index b4202f26a..a3271ccd5 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -49,12 +49,21 @@ 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 + #define SCM_I_INUMP(x) (2 & SCM_UNPACK (x)) -- cgit v1.2.3 From 3aecd36464b1d916991bcc57acd6ec42e1cabbdc Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 11 Mar 2014 21:33:48 -0400 Subject: SCM_I_INUM: Rewrite to avoid unspecified behavior when not using GNU C. * libguile/numbers.h (SCM_I_INUM): Unless using GNU C, use a portable implementation that avoids unspecified behavior. --- libguile/numbers.h | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/libguile/numbers.h b/libguile/numbers.h index a3271ccd5..b929b7a4a 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -65,12 +65,27 @@ typedef scm_t_int32 scm_t_wchar; #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_bits) (x)) << 2) + scm_tc2_int)) -#define SCM_I_INUM(x) (SCM_SRS ((scm_t_signed_bits) SCM_UNPACK (x), 2)) /* SCM_FIXABLE is true if its long argument can be encoded in an SCM_INUM. */ #define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM) -- cgit v1.2.3 From c6a2691fff2863209729aba5f54e3f874bbbf1c4 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sat, 8 Mar 2014 17:15:52 -0500 Subject: Test for deleted weak pairs in hash-for-each. * libguile/hashtab.c (scm_internal_hash_for_each_handle): Test for deleted weak pairs. * test-suite/tests/hash.test: Add test case. --- libguile/hashtab.c | 4 +++- test-suite/tests/hash.test | 12 ++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 9107ce550..44db05176 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -1464,7 +1464,9 @@ scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn, void *closure, handle = SCM_CAR (ls); if (!scm_is_pair (handle)) SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets); - fn (closure, handle); + if (!SCM_HASHTABLE_WEAK_P (table) + || !SCM_WEAK_PAIR_DELETED_P (handle)) + fn (closure, handle); ls = SCM_CDR (ls); } } diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test index 64d10bb38..4c21d7129 100644 --- a/test-suite/tests/hash.test +++ b/test-suite/tests/hash.test @@ -347,3 +347,15 @@ (pass-if (equal? 2 (hash-count (lambda (k v) (string? v)) table))))) + +;;; +;;; weak key hash table +;;; + +(with-test-prefix "weak key hash table" + (pass-if "hash-for-each after gc" + (let ((table (make-weak-key-hash-table))) + (hashq-set! table (list 'foo) 'bar) + (gc) + ;; Iterate over deleted weak ref without crashing. + (unspecified? (hash-for-each (lambda (key value) key) table))))) -- cgit v1.2.3 From da7e43a6e0dadb2f96e6e33163bb4d94715f7498 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 12 Mar 2014 14:24:11 +0100 Subject: build: Fix Gnulib compilation when $builddir != $srcdir. * configure.ac: Add -I$top_srcdir_absolute to 'CPPFLAGS'. Fixes out-of-source-tree compilation of lib/regex.c. Reported at . --- configure.ac | 3 +++ 1 file changed, 3 insertions(+) diff --git a/configure.ac b/configure.ac index 947296ba7..3969929ec 100644 --- a/configure.ac +++ b/configure.ac @@ -1636,6 +1636,9 @@ AC_SUBST(top_builddir_absolute) top_srcdir_absolute=`(cd $srcdir && pwd)` AC_SUBST(top_srcdir_absolute) +dnl Add -I flag so that lib/glthread/lock.h finds . +CPPFLAGS="-I$top_srcdir_absolute $CPPFLAGS" + dnl `sitedir' goes into libpath.h and the pkg-config file. pkgdatadir="$datadir/$PACKAGE_TARNAME" sitedir="$pkgdatadir/site/$GUILE_EFFECTIVE_VERSION" -- cgit v1.2.3 From 8cb0d6d7fa9aaac316c29a64c541336b51b6f93d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 12 Mar 2014 14:35:07 +0100 Subject: build: Don't include in native programs when cross-compiling. * libguile/Makefile.am (gen-scmconfig.$(OBJEXT)): When cross-compiling, pass -DCROSS_COMPILING=1. (c-tokenize.$(OBJEXT)): Likewise. * libguile/c-tokenize.lex (%top): Include only when CROSS_COMPILING is undefined. * libguile/gen-scmconfig.c: Likewise. --- libguile/Makefile.am | 24 +++++++++++++----------- libguile/c-tokenize.lex | 9 +++++++-- libguile/gen-scmconfig.c | 8 +++++--- 3 files changed, 25 insertions(+), 16 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 6a631d89f..9be6d0fda 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -60,12 +60,13 @@ gen_scmconfig_SOURCES = gen-scmconfig.c ## the generated config.h and gen-scmconfig.h. Nothing else from Guile ## is included by this code generator. gen-scmconfig.$(OBJEXT): gen-scmconfig.c - $(AM_V_GEN) \ - if [ "$(cross_compiling)" = "yes" ]; then \ - $(CC_FOR_BUILD) $(DEFS) $(DEFAULT_INCLUDES) -I$(top_builddir) \ - -c -o $@ $<; \ - else \ - $(COMPILE) -c -o $@ $<; \ + $(AM_V_GEN) \ + if [ "$(cross_compiling)" = "yes" ]; then \ + $(CC_FOR_BUILD) -DCROSS_COMPILING=1 $(DEFS) \ + $(DEFAULT_INCLUDES) -I$(top_builddir) \ + -c -o "$@" "$<"; \ + else \ + $(COMPILE) -c -o "$@" "$<"; \ fi ## Override default rule; this should run on BUILD host. @@ -92,11 +93,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. diff --git a/libguile/c-tokenize.lex b/libguile/c-tokenize.lex index a64b61da4..03fe9898c 100644 --- a/libguile/c-tokenize.lex +++ b/libguile/c-tokenize.lex @@ -1,7 +1,12 @@ %top{ /* Include before anything else because Gnulib headers such - as rely on it. */ -#include + as rely on it. + + However, when cross-compiling, don't include because it + contains information about the host, not about the build. */ +#ifndef CROSS_COMPILING +# include +#endif } %option noyywrap diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index 2f6fa6e6a..3c8be4f8e 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2003-2013 Free Software Foundation, Inc. +/* Copyright (C) 2003-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 @@ -132,8 +132,10 @@ **********************************************************************/ -#ifdef HAVE_CONFIG_H -# include +/* Don't include when cross-compiling because it contains + information about the host, not about the build machine. */ +#ifndef CROSS_COMPILING +# include #endif #include -- cgit v1.2.3 From de32a951c07243a307233ae2f2b478e636276e1e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 12 Mar 2014 15:18:27 +0100 Subject: build: Install libguile-2.0-gdb.scm after libguile-2.0.so. * libguile/Makefile.am (install-data-local): Rename to... (install-data-hook): ... this. This guarantees that the rule runs after libguile-2.0.so has been installed. --- libguile/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 9be6d0fda..db93929a7 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -450,7 +450,7 @@ EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = _scm.h \ install-exec-hook: rm -f $(DESTDIR)$(bindir)/guile-snarf.awk -install-data-local: libguile-2.0-gdb.scm +install-data-hook: libguile-2.0-gdb.scm @$(MKDIR_P) $(DESTDIR)$(libdir) ## We want to install libguile-2.0-gdb.scm as SOMETHING-gdb.scm. ## SOMETHING is the full name of the final library. We want to ignore -- cgit v1.2.3 From 21a7ba9b7e7e97854678677c7da4b42bd9faec66 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 12 Mar 2014 15:56:11 +0100 Subject: build: Remove libguile-2.0-gdb.scm and $infodir/dir upon uninstall. * libguile/Makefile.am (uninstall-data-hook): New target. --- libguile/Makefile.am | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index db93929a7..dd6d662d0 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -475,6 +475,12 @@ $(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 -- cgit v1.2.3 From 17d4daa8bd11176c2ebe0d35ac48da3d247094ff Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 13 Mar 2014 16:47:11 -0400 Subject: Include in gen-scmconfig even when cross-compiling. Partially reverts 8cb0d6d7fa9aaac316c29a64c541336b51b6f93d. * libguile/Makefile.am (gen-scmconfig.$(OBJEXT)): Remove -DCROSS_COMPILING=1 from cross-compiling case. * libguile/gen-scmconfig.c: Include regardless of whether CROSS_COMPILING is defined. --- libguile/Makefile.am | 13 ++++++------- libguile/gen-scmconfig.c | 8 +++----- 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index dd6d662d0..5decd99c0 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -60,13 +60,12 @@ gen_scmconfig_SOURCES = gen-scmconfig.c ## the generated config.h and gen-scmconfig.h. Nothing else from Guile ## is included by this code generator. gen-scmconfig.$(OBJEXT): gen-scmconfig.c - $(AM_V_GEN) \ - if [ "$(cross_compiling)" = "yes" ]; then \ - $(CC_FOR_BUILD) -DCROSS_COMPILING=1 $(DEFS) \ - $(DEFAULT_INCLUDES) -I$(top_builddir) \ - -c -o "$@" "$<"; \ - else \ - $(COMPILE) -c -o "$@" "$<"; \ + $(AM_V_GEN) \ + if [ "$(cross_compiling)" = "yes" ]; then \ + $(CC_FOR_BUILD) $(DEFS) $(DEFAULT_INCLUDES) -I$(top_builddir) \ + -c -o $@ $<; \ + else \ + $(COMPILE) -c -o $@ $<; \ fi ## Override default rule; this should run on BUILD host. diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index 3c8be4f8e..2f6fa6e6a 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2003-2014 Free Software Foundation, Inc. +/* Copyright (C) 2003-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 @@ -132,10 +132,8 @@ **********************************************************************/ -/* Don't include when cross-compiling because it contains - information about the host, not about the build machine. */ -#ifndef CROSS_COMPILING -# include +#ifdef HAVE_CONFIG_H +# include #endif #include -- cgit v1.2.3 From 950a966e643c5f979e73ae6fbce4d0424f2a6396 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 13 Mar 2014 23:21:48 -0400 Subject: Check SCM_USE_PTHREAD_THREADS using #if not #ifdef. * libguile/bdw-gc.h: Check SCM_USE_PTHREAD_THREADS using #if not #ifdef. --- libguile/bdw-gc.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/bdw-gc.h b/libguile/bdw-gc.h index 7aa757fed..d6f007713 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 -- cgit v1.2.3 From 2b509a2e37f9d3f98a1c8051629a339f499c0193 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 14 Mar 2014 15:07:10 -0400 Subject: SRFI-43 documentation tweaks * doc/ref/api-compound.texi (Vectors): Add cross-reference to SRFI-43. * doc/ref/srfi-modules.texi (SRFI-43 Selectors): Simplify description of 'vector-ref'. --- doc/ref/api-compound.texi | 6 ++++-- doc/ref/srfi-modules.texi | 4 ++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 0b14c4889..055de9935 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -@c 2007, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, +@c 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Compound Data Types @@ -673,6 +673,8 @@ that vectors are the special case of one dimensional non-uniform arrays and that most array procedures operate happily on vectors (@pxref{Arrays}). +Also see @ref{SRFI-43}, for a comprehensive vector library. + @menu * Vector Syntax:: Read syntax for vectors. * Vector Creation:: Dynamic vector creation and validation. diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 98ce1047b..b1776c6a0 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -4633,8 +4633,8 @@ comparisons are performed is unspecified. @subsubsection SRFI-43 Selectors @deffn {Scheme Procedure} vector-ref vec i -Return the value that the location in @var{vec} at @var{i} is mapped to -in the store. Indexing is based on zero. +Return the element at index @var{i} in @var{vec}. Indexing is based on +zero. @end deffn @deffn {Scheme Procedure} vector-length vec -- cgit v1.2.3 From f2de4fac885cb2964429657ea45a686e22bb3c2c Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 15 Mar 2014 13:23:21 -0400 Subject: Fix (system base types) on big-endian systems. * module/system/base/types.scm (cell->object): When reading stringbufs, use UTF-32BE on big-endian systems. --- module/system/base/types.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/module/system/base/types.scm b/module/system/base/types.scm index ed95347c4..4544a6ba0 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -428,7 +428,9 @@ using BACKEND." (stringbuf (bytevector->string buf "ISO-8859-1"))) (((_ & #x047f = (bitwise-ior #x400 %tc7-stringbuf)) len (bytevector buf (* 4 len))) - (stringbuf (bytevector->string buf "UTF-32LE"))) + (stringbuf (bytevector->string buf (match (native-endianness) + ('little "UTF-32LE") + ('big "UTF-32BE"))))) (((_ & #x7f = %tc7-bytevector) len address) (let ((bv-port (memory-port backend address len))) (get-bytevector-all bv-port))) -- cgit v1.2.3 From f1a13268fdc55a78700317b0e5d68649547db744 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 16 Mar 2014 23:24:34 +0100 Subject: build: Link 'test-unwind.c' against libgnu.la. * test-suite/standalone/Makefile.am (test_unwind_LDADD): Add libgnu.la, which provides 'rpl_mkstemp' on systems missing 'mkstemp'. --- test-suite/standalone/Makefile.am | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index a15d39587..a2cde42b9 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -1,7 +1,7 @@ ## Process this file with automake to produce Makefile.in. ## ## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, -## 2011, 2012, 2013 Free Software Foundation, Inc. +## 2011, 2012, 2013, 2014 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -139,7 +139,7 @@ TESTS += test-list # test-unwind test_unwind_SOURCES = test-unwind.c test_unwind_CFLAGS = ${test_cflags} -test_unwind_LDADD = $(LIBGUILE_LDADD) +test_unwind_LDADD = $(LIBGUILE_LDADD) $(top_builddir)/lib/libgnu.la check_PROGRAMS += test-unwind TESTS += test-unwind -- cgit v1.2.3 From 580ef7fcf4f9713bb2dc8ed4655649a576665316 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 17 Mar 2014 02:40:23 -0400 Subject: Documentation tweaks for the 'r7rs-symbols' read/print options. * doc/ref/api-data.texi (Symbol Read Syntax): Mention the 'r7rs-symbols' print option, and provide example code to enable both the read and print options. Add 'r7rs-symbols' to the concept index. --- doc/ref/api-data.texi | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 9fd353d75..acdf9ca2b 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -5526,6 +5526,8 @@ approach to properties, see @ref{Object Properties}. @node Symbol Read Syntax @subsubsection Extended Read Syntax for Symbols +@cindex r7rs-symbols + The read syntax for a symbol is a sequence of letters, digits, and @dfn{extended alphabetic characters}, beginning with a character that cannot begin a number. In addition, the special cases of @code{+}, @@ -5586,6 +5588,16 @@ double quotes. |\| is a vertical bar| @end example +Note that there's also an @code{r7rs-symbols} print option +(@pxref{Scheme Write}). To enable the use of this notation, evaluate +one or both of the following expressions: + +@example +(read-enable 'r7rs-symbols) +(print-enable 'r7rs-symbols) +@end example + + @node Symbol Uninterned @subsubsection Uninterned Symbols -- cgit v1.2.3 From cdf1ae89831166b4dfda411fdd959d718b0aed41 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 17 Mar 2014 02:42:38 -0400 Subject: Add first draft of NEWS for 2.0.10. * NEWS: Add first draft of changes in 2.0.10. --- NEWS | 366 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 365 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 59133019d..7f7752a77 100644 --- a/NEWS +++ b/NEWS @@ -1,10 +1,374 @@ Guile NEWS --- history of user-visible changes. -Copyright (C) 1996-2013 Free Software Foundation, Inc. +Copyright (C) 1996-2014 Free Software Foundation, Inc. See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. +Changes in 2.0.10 (since 2.0.9): + +[XXX This is a work-in-progress!! Search for "XXX" for things to fix. +Reorganization would also be helpful.] + +* Notable changes + +** New GDB extension to support Guile + +[XXX elaborate. Maybe also mention the addition of 'gdbinit' to the +distribution.] + +** Improved integration between R6RS and native Guile exceptions + +R6RS exception handlers, established using 'with-exception-handler' or +'guard', are now able to catch native Guile exceptions, which are +automatically converted into appropriate R6RS condition objects. + +** Support for HTTP proxies + +Guile's built-in web client now honors the 'http_proxy' environment +variable, as well as the new 'current-http-proxy' parameter. See +"Web Client" in the manual for details. + +** Lexical syntax improvements + +*** Support |...| symbol notation. + +Guile's core reader and printer now support the R7RS |...| notation +for writing symbols with arbitrary characters, as a more portable and +attractive alternative to Guile's native #{...}# notation. To enable +this notation by default, put one or both of the following in your +~/.guile: + + (read-enable 'r7rs-symbols) + (print-enable 'r7rs-symbols) + +*** Support '#true' and '#false' notation for booleans. + +The booleans '#t' and '#f' may now be written as '#true' and '#false' +for improved readability, per R7RS. + +*** Recognize '#\escape' character name. + +The escape character '#\esc' may now be written as '#\escape', per R7RS. + +*** Accept "\|" in string literals. + +The pipe character may now be preceded by a backslash, per R7RS. + +** Custom binary input ports now support 'setvbuf'. + +[XXX elaborate?] + +** SRFI-4 predicates and length accessors no longer accept arrays. + +Given that the SRFI-4 accessors don't work for arrays, the fact that the +predicates and length accessors returned true for arrays was a bug. + +** GUILE_PROGS now supports specifying a minimum required version. + +The 'GUILE_PROGS' autoconf macro in guile.m4 now allows an optional +argument to specify a minimum required Guile version. By default, it +requires Guile >= 2.0. A micro version can also be specified, e.g.: +GUILE_PROGS([2.0.10]) + +** Error reporting improvements + +*** Improved run-time error reporting in (ice-9 match). + +If no pattern matches in a 'match' form, the datum that failed to match +is printed along with the location of the failed 'match' invocation. + +*** Print the faulty object upon invalid-keyword errors. +*** Improved error reporting of procedures defined by define-inlinable. +*** Improved error reporting for misplaced ellipses in macro definitions. +*** Improved error checking in 'define-public' and 'module-add!'. +*** Improved error when 'include' form with relative path is not in a file. + +** Speed improvements + +*** 'scm_c_read' on ISO-8859-1 (e.g. binary) unbuffered ports is faster. +*** New inline asm for VM fixnum multiply, for faster overflow checking. +*** New inline asm for VM fixnum operations on ARM and 32-bit x86. +*** 'positive?' and 'negative?' are now compiled to VM primitives. +*** Numerical comparisons with more than 2 arguments are compiled to VM code. +*** Several R6RS bitwise operators have been optimized. + +** Miscellaneous changes [XXX not sure where these belong, if anywhere] + +*** Web: 'content-disposition' headers are now supported. +*** Web: 'uri-encode' hexadecimal percent-encoding is now uppercase. +*** Size argument to 'make-doubly-weak-hash-table' is now optional. +*** Timeout for 'unlock-mutex' and SRFI-18 'mutex-unlock!' may now be #f. + +** Gnulib update + +Guile's copy of Gnulib was updated to v0.1-92-g546ff82. The following +modules were imported from Gnulib: copysign, fsync, isfinite, link, +lstat, mkdir, mkstemp, readlink, rename, rmdir, and unistd. + +* Manual updates + +** Improve docs for 'eval-when'. + +Each 'eval-when' condition is now explained in detail, including +'expand' which was previously undocumented. (expand load eval) is now +the recommended set of conditions, instead of (compile load eval). +See "Eval When" in the manual, for details. + +** Update the section on SMOBs and memory management. + +[XXX elaborate, and cite manual] + +** Fixes + +[XXX Do these belong here or in the bug fixes section?] + +*** GOOPS: #:dsupers is the init keyword for the dsupers slot. +*** 'unfold-right' takes a tail, not a tail generator. +*** Clarify that 'append!' and 'reverse!' might not mutate. +*** Fix doc that incorrectly claimed (integer? +inf.0) => #t. + (http://bugs.gnu.org/16356) +*** Document that we support SRFI-62 (S-expression comments). +*** Document that we support SRFI-87 (=> in case clauses). +*** Document 'equal?' in the list of R6RS incompatibilities. +*** Remove outdated documentation of LTDL_LIBRARY_PATH. +*** Fix 'weak-vector?' doc: Weak hash tables are not weak vectors. +*** [XXX too minor?] Fix 'my-or' examples to use let-bound variable. + (http://bugs.gnu.org/14203) +*** [XXX too minor?] Fix nested block comment example. + +* New deprecations + +** General 'uniform-vector' interface + +This interface lacked both generality and specificity. The general +replacements are 'array-length', 'array-ref', and friends on the scheme +side, and the array handle interface on the C side. On the specific +side of things, there are the specific bytevector, SRFI-4, and bitvector +interfaces. + +** Use of the vector interface on arrays +** 'vector-length', 'vector-ref', and 'vector-set!' on weak vectors +** 'vector-length', 'vector-ref', and 'vector-set!' as primitive-generics + +Making the vector interface operate only on a single representation will +allow future versions of Guile to compile loops involving vectors to +more efficient native code. + +** 'htons', 'htonl', 'ntohs', 'ntohl' + +[XXX add justification]. Please use binary I/O with bytevectors, +together with the procedures described in "Interpreting Bytevector +Contents as Integers" in the manual. + +** 'gc-live-object-stats' + +It hasn't worked in the whole 2.0 series. There is no replacement, +unfortunately. + +** 'scm_c_program_source' + +[XXX add justification]. Please use 'scm_program_source' instead. + +* New interfaces + +[XXX Should some of these be moved to the "Notable Changes" section?] + +** Cooperative REPL servers + +This new facility supports REPLs that run at specified times within an +existing thread, for example in programs utilizing an event loop or in +single-threaded programs. This allows for safe access and mutation of +a program's data structures from the REPL without concern for thread +synchronization. See "Cooperative REPL Servers" in the manual for +details. + +** SRFI-43 (Vector Library) + +Guile now includes SRFI-43, a comprehensive library of vector operations +analogous to the SRFI-1 list library. See "SRFI-43" in the manual for +details. + +** SRFI-64 (A Scheme API for test suites) + +Guile now includes SRFI-64, a flexible framework for creating test +suites. The reference implementation of SRFI-64 has also been updated +to fully support earlier versions of Guile. + +** SRFI-111 (Boxes) + +See "SRFI-111" in the manual. + +** 'define-values' + +See "Binding multiple return values" in the manual. + +** Custom ellipsis identifiers using 'with-ellipsis' or SRFI-46. + +Guile now allows macro definitions to use identifiers other than '...' +as the ellipsis. This is convenient when writing macros that generate +macro definitions. The desired ellipsis identifier can given as the +first operand to 'syntax-rules', as specified SRFI-46 and R7RS, or by +using the new 'with-ellipsis' special form when writing procedural +macros. With this addition, Guile now fully supports SRFI-46. + +See "Specifying a Custom Ellipsis Identifier" and "Custom Ellipsis +Identifiers for syntax-case Macros" in the manual for details. + +** R7RS 'syntax-error' + +Guile now supports 'syntax-error', as specified by R7RS, allowing for +improved compile-time error reporting from 'syntax-rules' macros. See +"Reporting Syntax Errors in Macros" in the manual for details. + +** New procedures to convert association lists into hash tables + +Guile now includes the convenience procedures 'alist->hash-table', +'alist->hashq-table', 'alist->hashv-table', and 'alist->hashx-table'. +See "Hash Table Reference" in the manual. + +** New predicates: 'exact-integer?' and 'scm_is_exact_integer' + +See "Integers" in the manual. + +** 'weak-vector-length', 'weak-vector-ref', and 'weak-vector-set!' + +These should now be used to access weak vectors, instead of +'vector-length', 'vector-ref', and 'vector-set!'. + +* Build fixes + +** Fix build with clang 3.4. + +** MinGW build fixes +*** Do not add $(EXEEXT) to guild or guile-tools. +*** tests: Use double quotes around shell arguments, for Windows. +*** tests: Don't rely on $TMPDIR and /tmp on Windows. +*** tests: Skip FFI tests that use `qsort' when it's not accessible. +*** tests: Remove symlink only when it exists. +*** tests: Don't rely on `scm_call_2' being visible. + +** Fix computation of LIBLOBJS so dependencies work properly. + (http://bugs.gnu.org/14193) + +** Link 'test-unwind.c' against libgnu.la. + [XXX rewrite title; not sure where this belongs] + +* Bug fixes + +** Web: Fix web client with methods other than GET. + (http://bugs.gnu.org/15908) +** Web: Add Content-Length header for empty bodies. +** Web: Accept "UTC" as the zone offset in date headers. + (http://bugs.gnu.org/14128) +** Web: Don't throw if a response is longer than its Content-Length says. +** Web: Write out HTTP Basic auth headers correctly. + (http://bugs.gnu.org/14370) +** Web: Always print a path component in 'write-request-line'. +** Fix 'define-public' from (ice-9 curried-definitions). +** psyntax: toplevel variable definitions discard previous syntactic binding. + (http://bugs.gnu.org/11988) +** Fix thread-unsafe lazy initializations. +** Make (ice-9 popen) thread-safe. + (http://bugs.gnu.org/15683) +** Make guardians thread-safe. +** Make regexp_exec thread-safe. + (http://bugs.gnu.org/14404) +** vm: Gracefully handle stack overflows. + (http://bugs.gnu.org/15065) +** Fix 'rationalize'. + (http://bugs.gnu.org/14905) +** Fix inline asm for VM fixnum operations on x32. +** Fix 'SCM_SYSCALL' to really swallow EINTR. +** Hide EINTR returns from 'accept'. +** SRFI-19: Update the table of leap seconds. +** Add missing files to the test-suite Makefile. +** Make sure 'ftw' allows directory traversal when running as root. +** Fix 'hash-for-each' for weak hash tables. +** SRFI-18: Export 'current-thread'. + (http://bugs.gnu.org/16890) +** Fix inlining of tail list to apply. + (http://bugs.gnu.org/15533) +** Fix bug in remqueue in threads.c when removing last element. +** Fix build when '>>' on negative integers is not arithmetic. +** Fix 'bitwise-bit-count' for negative arguments. + (http://bugs.gnu.org/14864) +** Fix VM 'ash' for right shifts by large amounts. + (http://bugs.gnu.org/14864) +** Fix rounding in scm_i_divide2double for negative arguments. +** Avoid lossy conversion from inum to double in numerical comparisons. +** Fix numerical comparison of fractions to infinities. +** Allow fl+ and fl* to accept zero arguments. + (http://bugs.gnu.org/14869) +** flonum? returns false for complex number objects. + (http://bugs.gnu.org/14866) +** flfinite? applied to a NaN returns false. + (http://bugs.gnu.org/14868) +** Flonum operations always return flonums. + (http://bugs.gnu.org/14871) +** min and max: NaNs beat infinities, per R6RS errata. + (http://bugs.gnu.org/14865) +** Fix 'fxbit-count' for negative arguments. +** 'gcd' and 'lcm' support inexact integer arguments. + (http://bugs.gnu.org/14870) +** Fix R6RS 'fixnum-width'. + (http://bugs.gnu.org/14879) +** tests: Use shell constructs that /bin/sh on Solaris 10 can understand. + (http://bugs.gnu.org/14042) +** Fix display of symbols containing backslashes. + (http://bugs.gnu.org/15033) +** Fix truncated-print for uniform vectors. +** Define `AF_UNIX' only when Unix-domain sockets are supported. +** Decompiler: fix handling of empty 'case-lambda' expressions. +** Fix handling of signed zeroes and infinities in 'numerator' and 'denominator'. +** dereference-pointer: check for null pointer. +** Optimizer: Numerical comparisons are not negatable, for correct NaN handling. +** Compiler: Evaluate '-' and '/' in left-to-right order. + (for more robust floating-point arithmetic) +** snarf.h: Declare static const function name vars as SCM_UNUSED. +** chars.c: Remove duplicate 'const' specifiers. +** Modify SCM_UNPACK type check to avoid warnings in clang. +** Arrange so that 'file-encoding' does not truncate the encoding name. + (http://bugs.gnu.org/16463) +** Improve error checking in bytevector->uint-list and bytevector->sint-list. + (http://bugs.gnu.org/15100) +** Fix (ash -1 SCM_I_FIXNUM_BIT-1) to return a fixnum instead of a bignum. +** i18n: Fix null pointer dereference when locale info is missing. +** Fix 'string-copy!' to work properly with overlapping src/dest. +** Fix hashing of vectors to run in bounded time. +** 'port-position' works on CBIPs that do not support 'set-port-position!'. +** Custom binary input ports sanity-check the return value of 'read!'. +** bdw-gc.h: Check SCM_USE_PTHREAD_THREADS using #if not #ifdef. +** REPL Server: Don't establish a SIGINT handler. +** REPL Server: Redirect warnings to client socket. +** REPL Server: Improve robustness of 'stop-server-and-clients!'. +** Add srfi-16, srfi-30, srfi-46, srfi-62, srfi-87 to %cond-expand-features. +** Fix trap handlers to handle applicable structs. + (http://bugs.gnu.org/15691) +** Fix optional end argument in `uniform-vector-read!'. + (http://bugs.gnu.org/15370) +** Fix brainfuck->scheme compiler. + [XXX was this broken in 2.0.9?] + +** C standards conformance improvements + +[XXX Consider putting most of these in a different section, possibly +with a general overview of the improvements rather than individual +bullet items] + +*** Don't use the identifier 'noreturn'. + (http://bugs.gnu.org/15798) +*** Rewrite SCM_I_INUM to avoid unspecified behavior when not using GNU C. +*** Improve fallback implemention of SCM_SRS to avoid unspecified behavior. +*** SRFI-60: Reimplement 'rotate-bit-field' on inums to be more portable. +*** Improve compliance with C standards regarding signed integer shifts. +*** Avoid signed overflow in random.c. +*** VM: Avoid signed overflows in 'add1' and 'sub1'. +*** VM: Avoid overflow in ASM_ADD when the result is most-positive-fixnum. +*** read: Avoid signed integer overflow in 'read_decimal_integer'. + + + Changes in 2.0.9 (since 2.0.7): Note: 2.0.8 was a brown paper bag release that was never announced, but -- cgit v1.2.3 From 679ffce89c3ddb8f906df452e4884b128ea4655b Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 17 Mar 2014 02:54:47 -0400 Subject: Minor NEWS tweaks. * NEWS: Fix typo and improve wording in custom ellipsis entry. --- NEWS | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 7f7752a77..500b90e3d 100644 --- a/NEWS +++ b/NEWS @@ -207,10 +207,10 @@ See "Binding multiple return values" in the manual. Guile now allows macro definitions to use identifiers other than '...' as the ellipsis. This is convenient when writing macros that generate -macro definitions. The desired ellipsis identifier can given as the +macro definitions. The desired ellipsis identifier can be given as the first operand to 'syntax-rules', as specified SRFI-46 and R7RS, or by -using the new 'with-ellipsis' special form when writing procedural -macros. With this addition, Guile now fully supports SRFI-46. +using the new 'with-ellipsis' special form in procedural macros. With +this addition, Guile now fully supports SRFI-46. See "Specifying a Custom Ellipsis Identifier" and "Custom Ellipsis Identifiers for syntax-case Macros" in the manual for details. -- cgit v1.2.3 From b7faf399c1420567b017cdc7f900009ded175151 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 27 Feb 2014 17:16:29 +0100 Subject: Fix newline preservation in @example with lines beginning with @ * module/texinfo.scm (read-char-data): Preserve newlines in @example and similar environments in the case when the next line starts with an @. * test-suite/tests/texinfo.test ("test-texinfo->stexinfo"): Add a test. --- module/texinfo.scm | 6 ++++-- test-suite/tests/texinfo.test | 4 +++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/module/texinfo.scm b/module/texinfo.scm index 91bb46d8d..02fec16a1 100644 --- a/module/texinfo.scm +++ b/module/texinfo.scm @@ -1,6 +1,6 @@ ;;;; (texinfo) -- parsing of texinfo into SXML ;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. ;;;; Copyright (C) 2004, 2009 Andy Wingo ;;;; Copyright (C) 2001,2002 Oleg Kiselyov ;;;; @@ -765,7 +765,9 @@ Examples: (let* ((token (read-command-token port)) (end? (eq? (token-kind token) 'END))) (values - (handle str-handler fragment (if end? "" " ") seed) + (handle str-handler fragment + (if end? "" (if preserve-ws? "\n" " ")) + seed) token))) ((and (not preserve-ws?) (eq? c #\newline)) ;; paragraph-separator ::= #\newline #\newline+ diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test index 2cb4a7187..9c6722f57 100644 --- a/test-suite/tests/texinfo.test +++ b/test-suite/tests/texinfo.test @@ -1,6 +1,6 @@ ;;;; texinfo.test -*- scheme -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. ;;;; Copyright (C) 2001,2002 Oleg Kiselyov ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -232,6 +232,8 @@ (test-body "@example\n foo asdf asd sadf asd \n@end example\n" '((example " foo asdf asd sadf asd "))) + (test-body "@example\n@{\n@}\n@end example\n" + '((example "{\n}"))) (test-body (join-lines "@quotation" "@example" -- cgit v1.2.3 From c68b9470e9d03e64e9b82d20d2eadf2d1745ab8b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Mar 2014 21:55:26 +0100 Subject: Update NEWS. * NEWS: Move "New interfaces" higher. Complement. --- NEWS | 150 +++++++++++++++++++++++++++++++++---------------------------------- 1 file changed, 73 insertions(+), 77 deletions(-) diff --git a/NEWS b/NEWS index 500b90e3d..c9ef852ef 100644 --- a/NEWS +++ b/NEWS @@ -14,8 +14,9 @@ Reorganization would also be helpful.] ** New GDB extension to support Guile -[XXX elaborate. Maybe also mention the addition of 'gdbinit' to the -distribution.] +Guile now comes with an extension for GDB 7.8 or later (unreleased at +the time of writing) that simplifies debugging of C code that uses +Guile. See "GDB Support" in the manual. ** Improved integration between R6RS and native Guile exceptions @@ -57,7 +58,8 @@ The pipe character may now be preceded by a backslash, per R7RS. ** Custom binary input ports now support 'setvbuf'. -[XXX elaborate?] +Until now, ports returned by 'make-custom-binary-input-port' were always +full-buffered. Now, their buffering mode can be changed using 'setvbuf'. ** SRFI-4 predicates and length accessors no longer accept arrays. @@ -106,74 +108,8 @@ Guile's copy of Gnulib was updated to v0.1-92-g546ff82. The following modules were imported from Gnulib: copysign, fsync, isfinite, link, lstat, mkdir, mkstemp, readlink, rename, rmdir, and unistd. -* Manual updates - -** Improve docs for 'eval-when'. - -Each 'eval-when' condition is now explained in detail, including -'expand' which was previously undocumented. (expand load eval) is now -the recommended set of conditions, instead of (compile load eval). -See "Eval When" in the manual, for details. - -** Update the section on SMOBs and memory management. - -[XXX elaborate, and cite manual] - -** Fixes - -[XXX Do these belong here or in the bug fixes section?] - -*** GOOPS: #:dsupers is the init keyword for the dsupers slot. -*** 'unfold-right' takes a tail, not a tail generator. -*** Clarify that 'append!' and 'reverse!' might not mutate. -*** Fix doc that incorrectly claimed (integer? +inf.0) => #t. - (http://bugs.gnu.org/16356) -*** Document that we support SRFI-62 (S-expression comments). -*** Document that we support SRFI-87 (=> in case clauses). -*** Document 'equal?' in the list of R6RS incompatibilities. -*** Remove outdated documentation of LTDL_LIBRARY_PATH. -*** Fix 'weak-vector?' doc: Weak hash tables are not weak vectors. -*** [XXX too minor?] Fix 'my-or' examples to use let-bound variable. - (http://bugs.gnu.org/14203) -*** [XXX too minor?] Fix nested block comment example. - -* New deprecations - -** General 'uniform-vector' interface - -This interface lacked both generality and specificity. The general -replacements are 'array-length', 'array-ref', and friends on the scheme -side, and the array handle interface on the C side. On the specific -side of things, there are the specific bytevector, SRFI-4, and bitvector -interfaces. - -** Use of the vector interface on arrays -** 'vector-length', 'vector-ref', and 'vector-set!' on weak vectors -** 'vector-length', 'vector-ref', and 'vector-set!' as primitive-generics - -Making the vector interface operate only on a single representation will -allow future versions of Guile to compile loops involving vectors to -more efficient native code. - -** 'htons', 'htonl', 'ntohs', 'ntohl' - -[XXX add justification]. Please use binary I/O with bytevectors, -together with the procedures described in "Interpreting Bytevector -Contents as Integers" in the manual. - -** 'gc-live-object-stats' - -It hasn't worked in the whole 2.0 series. There is no replacement, -unfortunately. - -** 'scm_c_program_source' - -[XXX add justification]. Please use 'scm_program_source' instead. - * New interfaces -[XXX Should some of these be moved to the "Notable Changes" section?] - ** Cooperative REPL servers This new facility supports REPLs that run at specified times within an @@ -236,9 +172,73 @@ See "Integers" in the manual. These should now be used to access weak vectors, instead of 'vector-length', 'vector-ref', and 'vector-set!'. +* Manual updates + +** Improve docs for 'eval-when'. + +Each 'eval-when' condition is now explained in detail, including +'expand' which was previously undocumented. (expand load eval) is now +the recommended set of conditions, instead of (compile load eval). +See "Eval When" in the manual, for details. + +** Update the section on SMOBs and memory management. + +See "Defining New Types (Smobs)" in the manual. + +** Fixes + +*** GOOPS: #:dsupers is the init keyword for the dsupers slot. +*** 'unfold-right' takes a tail, not a tail generator. +*** Clarify that 'append!' and 'reverse!' might not mutate. +*** Fix doc that incorrectly claimed (integer? +inf.0) => #t. + (http://bugs.gnu.org/16356) +*** Document that we support SRFI-62 (S-expression comments). +*** Document that we support SRFI-87 (=> in case clauses). +*** Document 'equal?' in the list of R6RS incompatibilities. +*** Remove outdated documentation of LTDL_LIBRARY_PATH. +*** Fix 'weak-vector?' doc: Weak hash tables are not weak vectors. +*** Fix 'my-or' examples to use let-bound variable. + (http://bugs.gnu.org/14203) + +* New deprecations + +** General 'uniform-vector' interface + +This interface lacked both generality and specificity. The general +replacements are 'array-length', 'array-ref', and friends on the scheme +side, and the array handle interface on the C side. On the specific +side of things, there are the specific bytevector, SRFI-4, and bitvector +interfaces. + +** Use of the vector interface on arrays +** 'vector-length', 'vector-ref', and 'vector-set!' on weak vectors +** 'vector-length', 'vector-ref', and 'vector-set!' as primitive-generics + +Making the vector interface operate only on a single representation will +allow future versions of Guile to compile loops involving vectors to +more efficient native code. + +** 'htons', 'htonl', 'ntohs', 'ntohl' + +These procedures, like their C counterpart, were used to convert numbers +to/from network byte order, typically in conjunction with the +now-deprecated uniform vector API. + +This functionality is now covered by the bytevector and binary I/O APIs. +See "Interpreting Bytevector Contents as Integers" in the manual. + +** 'gc-live-object-stats' + +It hasn't worked in the whole 2.0 series. There is no replacement, +unfortunately. + +** 'scm_c_program_source' + +[XXX add justification]. Please use 'scm_program_source' instead. + * Build fixes -** Fix build with clang 3.4. +** Fix build with Clang 3.4. ** MinGW build fixes *** Do not add $(EXEEXT) to guild or guile-tools. @@ -251,9 +251,6 @@ These should now be used to access weak vectors, instead of ** Fix computation of LIBLOBJS so dependencies work properly. (http://bugs.gnu.org/14193) -** Link 'test-unwind.c' against libgnu.la. - [XXX rewrite title; not sure where this belongs] - * Bug fixes ** Web: Fix web client with methods other than GET. @@ -348,13 +345,12 @@ These should now be used to access weak vectors, instead of ** Fix optional end argument in `uniform-vector-read!'. (http://bugs.gnu.org/15370) ** Fix brainfuck->scheme compiler. - [XXX was this broken in 2.0.9?] +** texinfo: Fix newline preservation in @example with lines beginning with @ ** C standards conformance improvements -[XXX Consider putting most of these in a different section, possibly -with a general overview of the improvements rather than individual -bullet items] +Improvements and bug fixes were made to the C part of Guile's run-time +support (libguile). *** Don't use the identifier 'noreturn'. (http://bugs.gnu.org/15798) -- cgit v1.2.3 From 77326d36494f40736a9e05f0ef912cd9763871cb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 17 Mar 2014 22:05:39 +0100 Subject: Update NEWS * NEWS: Update. --- NEWS | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index c9ef852ef..78e48ec94 100644 --- a/NEWS +++ b/NEWS @@ -234,7 +234,8 @@ unfortunately. ** 'scm_c_program_source' -[XXX add justification]. Please use 'scm_program_source' instead. +This internal VM function was not meant to be public. Use +'scm_procedure_source' instead. * Build fixes -- cgit v1.2.3 From 6a450390caca3fa62bb611843fea53f729be278a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Mar 2014 22:13:09 +0100 Subject: Update NEWS. * NEWS: Remove last 'XXX'. --- NEWS | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/NEWS b/NEWS index 78e48ec94..15911bf2b 100644 --- a/NEWS +++ b/NEWS @@ -7,9 +7,6 @@ Please send Guile bug reports to bug-guile@gnu.org. Changes in 2.0.10 (since 2.0.9): -[XXX This is a work-in-progress!! Search for "XXX" for things to fix. -Reorganization would also be helpful.] - * Notable changes ** New GDB extension to support Guile @@ -95,7 +92,7 @@ is printed along with the location of the failed 'match' invocation. *** Numerical comparisons with more than 2 arguments are compiled to VM code. *** Several R6RS bitwise operators have been optimized. -** Miscellaneous changes [XXX not sure where these belong, if anywhere] +** Miscellaneous *** Web: 'content-disposition' headers are now supported. *** Web: 'uri-encode' hexadecimal percent-encoding is now uppercase. -- cgit v1.2.3 From f755f14e32aca8ecaabab759db0dd88072d0ca45 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Mar 2014 23:06:21 +0100 Subject: Fix typo in NEWS. --- NEWS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 15911bf2b..5cfba1c76 100644 --- a/NEWS +++ b/NEWS @@ -141,7 +141,7 @@ See "Binding multiple return values" in the manual. Guile now allows macro definitions to use identifiers other than '...' as the ellipsis. This is convenient when writing macros that generate macro definitions. The desired ellipsis identifier can be given as the -first operand to 'syntax-rules', as specified SRFI-46 and R7RS, or by +first operand to 'syntax-rules', as specified in SRFI-46 and R7RS, or by using the new 'with-ellipsis' special form in procedural macros. With this addition, Guile now fully supports SRFI-46. -- cgit v1.2.3 From 92b793da2b43af0ed470c43dc7e41409ca61f1b4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Mar 2014 23:18:38 +0100 Subject: Bump version number for 2.0.10. * GUILE-VERSION (GUILE_MICRO_VERSION): Increment. (LIBGUILE_INTERFACE_REVISION): Increment. --- GUILE-VERSION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 4ebba1e55..00cf57393 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 GUILE_MINOR_VERSION=0 -GUILE_MICRO_VERSION=9 +GUILE_MICRO_VERSION=10 GUILE_EFFECTIVE_VERSION=2.0 @@ -19,6 +19,6 @@ GUILE_EFFECTIVE_VERSION=2.0 # change these. LIBGUILE_INTERFACE_CURRENT=29 -LIBGUILE_INTERFACE_REVISION=0 +LIBGUILE_INTERFACE_REVISION=1 LIBGUILE_INTERFACE_AGE=7 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}" -- cgit v1.2.3 From 2be7131ee0c38336483226657872a8faa62a2562 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 19 Mar 2014 22:41:19 +0100 Subject: Fix breakage of SRFI-4 C accessors * libguile/srfi-4.c (DEFINE_SRFI_4_C_FUNCS): Fix bad assumption that width was a byte width. Thanks very much to Barry Fishman for the report, and to Daniel Llorens for tracking it down. * test-suite/standalone/Makefile.am (test_srfi_4_CFLAGS): * test-suite/standalone/test-srfi-4.c: Add test. --- libguile/srfi-4.c | 5 ++- test-suite/standalone/Makefile.am | 7 +++ test-suite/standalone/test-srfi-4.c | 87 +++++++++++++++++++++++++++++++++++++ 3 files changed, 97 insertions(+), 2 deletions(-) create mode 100644 test-suite/standalone/test-srfi-4.c diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index 7b25a3b4d..8257b2e45 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/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index a2cde42b9..7c4633a25 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -211,6 +211,13 @@ test_scm_c_bind_keyword_arguments_LDADD = $(LIBGUILE_LDADD) check_PROGRAMS += test-scm-c-bind-keyword-arguments TESTS += test-scm-c-bind-keyword-arguments +# test-srfi-4 +test_srfi_4_SOURCES = test-srfi-4.c +test_srfi_4_CFLAGS = ${test_cflags} +test_srfi_4_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-srfi-4 +TESTS += test-srfi-4 + if HAVE_SHARED_LIBRARIES # test-extensions diff --git a/test-suite/standalone/test-srfi-4.c b/test-suite/standalone/test-srfi-4.c new file mode 100644 index 000000000..22e079c1b --- /dev/null +++ b/test-suite/standalone/test-srfi-4.c @@ -0,0 +1,87 @@ +/* Copyright (C) 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 + * the License, or (at your option) any later version. + * + * This library 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 + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include + +#include +#include + +static void +test_writable_elements () +{ + SCM elts = scm_list_4 (scm_from_int (1), scm_from_int (2), + scm_from_int (3), scm_from_int (4)); + + { + SCM v = scm_u32vector (elts); + size_t len; + ssize_t inc; + scm_t_array_handle h; + scm_t_uint32 *elts = scm_u32vector_writable_elements (v, &h, &len, &inc); + assert (len == 4); + assert (inc == 1); + assert (elts[0] == 1); + assert (elts[3] == 4); + scm_array_handle_release (&h); + } + + { + SCM v = scm_f32vector (elts); + size_t len; + ssize_t inc; + scm_t_array_handle h; + float *elts = scm_f32vector_writable_elements (v, &h, &len, &inc); + assert (len == 4); + assert (inc == 1); + assert (elts[0] == 1.0); + assert (elts[3] == 4.0); + scm_array_handle_release (&h); + } + + { + SCM v = scm_c32vector (elts); + size_t len; + ssize_t inc; + scm_t_array_handle h; + float *elts = scm_c32vector_writable_elements (v, &h, &len, &inc); + assert (len == 4); + assert (inc == 1); + assert (elts[0] == 1.0); + assert (elts[1] == 0.0); + assert (elts[6] == 4.0); + assert (elts[7] == 0.0); + scm_array_handle_release (&h); + } +} + +static void +tests (void *data, int argc, char **argv) +{ + test_writable_elements (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} -- cgit v1.2.3 From e26ab067b2073c1eb5ace13d069674515b9f97c6 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 19 Mar 2014 17:55:20 -0400 Subject: simple-format: Don't assume the current output port is valid. * libguile/print.c (scm_simple_format): Validate the current output port. --- libguile/print.c | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/print.c b/libguile/print.c index ae98af405..60683b517 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1468,6 +1468,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 (0, destination); } else if (scm_is_false (destination)) { -- cgit v1.2.3 From 5dcbcfcef8eefd1f9e57d8ba69efe1ca945c95b1 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 19 Mar 2014 23:36:46 -0400 Subject: Fix (rnrs io simple) to open file ports in textual mode. Fixes . Reported and diagnosed by Xin Wang . * module/rnrs/io/simple.scm (open-input-file, open-output-file): Pass missing buffer-mode argument to open-file-{input,output}-port. Previously, (native-transcoder) was incorrectly passed as the buffer-mode argument, so no transcoder was provided, thus creating a binary port. --- module/rnrs/io/simple.scm | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/module/rnrs/io/simple.scm b/module/rnrs/io/simple.scm index 031628b38..5eb396f0e 100644 --- a/module/rnrs/io/simple.scm +++ b/module/rnrs/io/simple.scm @@ -1,6 +1,6 @@ ;;; simple.scm --- The R6RS simple I/O library -;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 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 @@ -91,6 +91,7 @@ eof-object eof-object? file-options + buffer-mode native-transcoder get-char lookahead-char @@ -131,10 +132,16 @@ (lambda (port) (with-output-to-port port thunk)))) (define (open-input-file filename) - (open-file-input-port filename (file-options) (native-transcoder))) + (open-file-input-port filename + (file-options) + (buffer-mode block) + (native-transcoder))) (define (open-output-file filename) - (open-file-output-port filename (file-options) (native-transcoder))) + (open-file-output-port filename + (file-options) + (buffer-mode block) + (native-transcoder))) (define close-input-port close-port) (define close-output-port close-port) -- cgit v1.2.3 From f2c3d29fd256ff4b6022d9af98543be7c625422e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Mar 2014 09:40:42 +0100 Subject: tests: Check 'simple-format' with closed current-output-port. This is a follow-up to e26ab06. * libguile/print.c (scm_simple_format): Pass 1 to SCM_VALIDATE_OPORT_VALUE, for 'destination'. * test-suite/tests/format.test ("simple-format"): Add test. --- libguile/print.c | 2 +- test-suite/tests/format.test | 16 ++++++++++++++++ 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/libguile/print.c b/libguile/print.c index 60683b517..7e27f7670 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1468,7 +1468,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 (0, destination); + SCM_VALIDATE_OPORT_VALUE (1, destination); } else if (scm_is_false (destination)) { diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test index 334984703..cc31942cc 100644 --- a/test-suite/tests/format.test +++ b/test-suite/tests/format.test @@ -24,6 +24,22 @@ #:use-module (ice-9 format)) +(with-test-prefix "simple-format" + (pass-if-exception "current-output-port is closed" + exception:wrong-type-arg + ;; This used to segfault in Guile <= 2.0.10. + (let ((old (current-output-port)) + (new (%make-void-port "w"))) + (dynamic-wind + (lambda () + (set-current-output-port new) + (close-port new)) + (lambda () + (simple-format #t "hello, closed port!") + #t) + (lambda () + (set-current-output-port old)))))) + ;;; FORMAT Basic Output (with-test-prefix "format basic output" -- cgit v1.2.3 From 0c1f2b0e0d3940fc0d4f3a902d9c487db15f14d5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Mar 2014 09:43:01 +0100 Subject: tests: Add #undef NDEBUG when using . * test-suite/standalone/test-loose-ends.c, test-suite/standalone/test-num2integral.c, test-suite/standalone/test-round.c, test-suite/standalone/test-scm-c-bind-keyword-arguments.c, test-suite/standalone/test-scm-c-read.c, test-suite/standalone/test-scm-values.c, test-suite/standalone/test-smob-mark.c, test-suite/standalone/test-srfi-4.c: Add #undef NDEBUG. --- test-suite/standalone/test-loose-ends.c | 4 +++- test-suite/standalone/test-num2integral.c | 4 +++- test-suite/standalone/test-round.c | 4 +++- test-suite/standalone/test-scm-c-bind-keyword-arguments.c | 4 +++- test-suite/standalone/test-scm-c-read.c | 4 +++- test-suite/standalone/test-scm-values.c | 4 +++- test-suite/standalone/test-smob-mark.c | 4 +++- test-suite/standalone/test-srfi-4.c | 3 +++ 8 files changed, 24 insertions(+), 7 deletions(-) diff --git a/test-suite/standalone/test-loose-ends.c b/test-suite/standalone/test-loose-ends.c index b4ea5b94a..40b358b99 100644 --- a/test-suite/standalone/test-loose-ends.c +++ b/test-suite/standalone/test-loose-ends.c @@ -3,7 +3,7 @@ * Test items of the Guile C API that aren't covered by any other tests. */ -/* Copyright (C) 2009, 2012 Free Software Foundation, Inc. +/* Copyright (C) 2009, 2012, 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 @@ -25,6 +25,8 @@ # include #endif +#undef NDEBUG + #include #include diff --git a/test-suite/standalone/test-num2integral.c b/test-suite/standalone/test-num2integral.c index 0246a3303..4f5629d65 100644 --- a/test-suite/standalone/test-num2integral.c +++ b/test-suite/standalone/test-num2integral.c @@ -1,5 +1,5 @@ /* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 2010, - * 2012 Free Software Foundation, Inc. + * 2012, 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 @@ -21,6 +21,8 @@ # include #endif +#undef NDEBUG + #include #include diff --git a/test-suite/standalone/test-round.c b/test-suite/standalone/test-round.c index 150c8816e..2cd6fd54e 100644 --- a/test-suite/standalone/test-round.c +++ b/test-suite/standalone/test-round.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2004, 2006, 2008, 2009, 2011 Free Software Foundation, Inc. +/* Copyright (C) 2004, 2006, 2008, 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 @@ -20,6 +20,8 @@ # include #endif +#undef NDEBUG + #include #include #include diff --git a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c index ad0722ce8..f4cd53d84 100644 --- a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c +++ b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2013 Free Software Foundation, Inc. +/* Copyright (C) 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 @@ -20,6 +20,8 @@ # include #endif +#undef NDEBUG + #include #include diff --git a/test-suite/standalone/test-scm-c-read.c b/test-suite/standalone/test-scm-c-read.c index 4111cd0f5..5f11e7565 100644 --- a/test-suite/standalone/test-scm-c-read.c +++ b/test-suite/standalone/test-scm-c-read.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2008 Free Software Foundation, Inc. +/* Copyright (C) 2008, 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 @@ -23,6 +23,8 @@ # include #endif +#undef NDEBUG + #include #include diff --git a/test-suite/standalone/test-scm-values.c b/test-suite/standalone/test-scm-values.c index ece62dab6..06f57bedd 100644 --- a/test-suite/standalone/test-scm-values.c +++ b/test-suite/standalone/test-scm-values.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2012 Free Software Foundation, Inc. +/* Copyright (C) 2012, 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 @@ -20,6 +20,8 @@ # include #endif +#undef NDEBUG + #include #include #include diff --git a/test-suite/standalone/test-smob-mark.c b/test-suite/standalone/test-smob-mark.c index d9db9a651..86566af76 100644 --- a/test-suite/standalone/test-smob-mark.c +++ b/test-suite/standalone/test-smob-mark.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2013 Free Software Foundation, Inc. +/* Copyright (C) 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 @@ -20,6 +20,8 @@ #include #endif +#undef NDEBUG + #include #include #include diff --git a/test-suite/standalone/test-srfi-4.c b/test-suite/standalone/test-srfi-4.c index 22e079c1b..b49e666cc 100644 --- a/test-suite/standalone/test-srfi-4.c +++ b/test-suite/standalone/test-srfi-4.c @@ -20,6 +20,9 @@ # include #endif +/* Make sure the assertions are tested. */ +#undef NDEBUG + #include #include -- cgit v1.2.3 From d4d11cf39de5b30a136f89f1ebc32673e981c70f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Mar 2014 21:20:59 +0100 Subject: Update NEWS. --- NEWS | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/NEWS b/NEWS index 5cfba1c76..0292dcd3c 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,14 @@ See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. +Changes in 2.0.11 (since 2.0.10): + +This release fixes an embarrassing regression introduced in the C +interface to SRFI-4 vectors. See + +for details. + + Changes in 2.0.10 (since 2.0.9): * Notable changes -- cgit v1.2.3 From 972fb41f0ce124d97f5cf64bde1075510cd21e18 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Mar 2014 21:21:21 +0100 Subject: Bump version number for 2.0.11. * GUILE-VERSION (GUILE_MICRO_VERSION): Increment. (LIBGUILE_INTERFACE_REVISION): Increment. --- GUILE-VERSION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 00cf57393..943f62cad 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 GUILE_MINOR_VERSION=0 -GUILE_MICRO_VERSION=10 +GUILE_MICRO_VERSION=11 GUILE_EFFECTIVE_VERSION=2.0 @@ -19,6 +19,6 @@ GUILE_EFFECTIVE_VERSION=2.0 # change these. LIBGUILE_INTERFACE_CURRENT=29 -LIBGUILE_INTERFACE_REVISION=1 +LIBGUILE_INTERFACE_REVISION=2 LIBGUILE_INTERFACE_AGE=7 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}" -- cgit v1.2.3 From 8d124d207738be0b43dfc235a5d72519a2ab5db9 Mon Sep 17 00:00:00 2001 From: Nathaniel Alderson Date: Thu, 19 Sep 2013 14:02:26 -0700 Subject: Calculate usecs correctly in thread-sleep! * module/srfi/srfi-18.scm (thread-sleep!): Correctly compute microseconds. * test-suite/tests/srfi-18.test: Add test. --- module/srfi/srfi-18.scm | 2 +- test-suite/tests/srfi-18.test | 8 +++++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 5b5b2a686..01550c310 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -236,7 +236,7 @@ (list timeout) '())))) (secs (inexact->exact (truncate t))) - (usecs (inexact->exact (truncate (* (- t secs) 1000))))) + (usecs (inexact->exact (truncate (* (- t secs) 1000000))))) (and (> secs 0) (sleep secs)) (and (> usecs 0) (usleep usecs)) *unspecified*)) diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index 47f8f7f40..ab055132e 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -96,6 +96,12 @@ (let ((old-secs (car (current-time)))) (unspecified? (thread-sleep! (+ (time->seconds (current-time))))))) + (pass-if "thread sleeps fractions of a second" + (let* ((current (time->seconds (current-time))) + (future (+ current 0.5))) + (thread-sleep! future) + (>= (time->seconds (current-time)) future))) + (pass-if "thread does not sleep on past time" (let ((past-time (seconds->time (- (time->seconds (current-time)) 2)))) (unspecified? (thread-sleep! past-time))))) @@ -479,4 +485,4 @@ (eq? (uncaught-exception-reason obj) 'foo) (set! success #t))) (lambda () (thread-join! t))) - success))))) \ No newline at end of file + success))))) -- cgit v1.2.3 From 0ece4850c5423d53db3245f57681053486327aa3 Mon Sep 17 00:00:00 2001 From: David Kastrup Date: Tue, 1 Apr 2014 16:24:29 +0200 Subject: Make reverse! forego the cost of SCM_VALIDATE_LIST * libguile/list.c (scm_reverse_x): Do not validate first argument to reverse! in advance. Instead undo reversal in error case. Signed-off-by: David Kastrup Signed-off-by: Mark H Weaver --- libguile/list.c | 41 ++++++++++++++++++++++++++++++++++++----- 1 file changed, 36 insertions(+), 5 deletions(-) diff --git a/libguile/list.c b/libguile/list.c index d30f9e847..01f23c0f0 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 -- cgit v1.2.3 From b27ad2f394c5e4465f5cdee748534d013919cfa1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 14 Apr 2014 16:12:14 +0200 Subject: Readline history preserves newlines * guile-readline/ice-9/readline.scm (make-readline-port): Preserve newlines. This preserves the semantics of history entries that contain until-end-of-line comments using `;'. --- guile-readline/ice-9/readline.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm index a9f7cdc6d..cfaaef362 100644 --- a/guile-readline/ice-9/readline.scm +++ b/guile-readline/ice-9/readline.scm @@ -1,6 +1,6 @@ ;;;; readline.scm --- support functions for command-line editing ;;;; -;;;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006, 2009, 2010, 2011, 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 @@ -105,7 +105,7 @@ (set! history-buffer (if history-buffer (string-append history-buffer - " " + "\n" str) str))) str))))) -- cgit v1.2.3 From d2fcbb193b67106d0c0b57cd1e988acf2d30ace7 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 16 Apr 2014 00:49:40 -0400 Subject: Update libgc URL in README. * README: Update libgc URL. Suggested by Ian Grant . --- README | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README b/README index 215f9e53e..92d786c06 100644 --- a/README +++ b/README @@ -82,7 +82,7 @@ Guile requires the following external packages: libgc (aka. the Boehm-Demers-Weiser garbage collector) is the conservative garbage collector used by Guile. It is available - from http://www.hpl.hp.com/personal/Hans_Boehm/gc/ . + from http://www.hboehm.info/gc/ . - libffi -- cgit v1.2.3 From 7eaa92ffa9594025d989d5584750b72fe5797c20 Mon Sep 17 00:00:00 2001 From: Dmitry Bogatov Date: Thu, 10 Apr 2014 09:23:28 +0400 Subject: Fix memory leak on `realloc' failure * libguile/script.c (realloc0): New helper. (script_read_arg, scm_get_meta_args): Use realloc0, not realloc. Signed-off-by: Dmitry Bogatov --- libguile/script.c | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/libguile/script.c b/libguile/script.c index 0d7b28fa8..b6910bad3 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -219,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) @@ -244,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; } @@ -327,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); -- cgit v1.2.3 From 4a81f5b5d3800aafbc25452e50459c1ba6e29fea Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 24 Apr 2014 11:16:21 +0200 Subject: build: Honor program name transformation in 'guild'. * configure.ac: Remove erroneous 'guile_program_name' substitute; see for details. Remove 'meta/guild' config file. * meta/Makefile.am (guild): New target. (CLEANFILES): Add 'guild'. * meta/guild.in: Remove 'prefix' and 'exec_prefix' definitions; use @installed_guile@. --- configure.ac | 5 ----- meta/Makefile.am | 14 ++++++++++++-- meta/guild.in | 6 ++---- 3 files changed, 14 insertions(+), 11 deletions(-) diff --git a/configure.ac b/configure.ac index 3969929ec..9f87809b5 100644 --- a/configure.ac +++ b/configure.ac @@ -1644,10 +1644,6 @@ pkgdatadir="$datadir/$PACKAGE_TARNAME" sitedir="$pkgdatadir/site/$GUILE_EFFECTIVE_VERSION" AC_SUBST([sitedir]) -dnl Name of the `guile' program. -guile_program_name="`echo guile | "$SED" "$program_transform_name"`" -AC_SUBST([guile_program_name]) - # Additional SCM_I_GSC definitions are above. AC_SUBST([SCM_I_GSC_GUILE_DEBUG]) AC_SUBST([SCM_I_GSC_ENABLE_DEPRECATED]) @@ -1684,7 +1680,6 @@ GUILE_CONFIG_SCRIPT([benchmark-guile]) GUILE_CONFIG_SCRIPT([meta/guile]) GUILE_CONFIG_SCRIPT([meta/uninstalled-env]) GUILE_CONFIG_SCRIPT([meta/gdb-uninstalled-guile]) -GUILE_CONFIG_SCRIPT([meta/guild]) GUILE_CONFIG_SCRIPT([libguile/guile-snarf]) GUILE_CONFIG_SCRIPT([libguile/guile-snarf-docs]) GUILE_CONFIG_SCRIPT([test-suite/standalone/test-use-srfi]) diff --git a/meta/Makefile.am b/meta/Makefile.am index 2d3c462a4..102b7974d 100644 --- a/meta/Makefile.am +++ b/meta/Makefile.am @@ -2,7 +2,7 @@ ## Jim Blandy --- September 1997 ## ## Copyright (C) 1998, 1999, 2001, 2006, 2007, 2008, 2009, 2011, -## 2012, 2013 Free Software Foundation, Inc. +## 2012, 2013, 2014 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -54,4 +54,14 @@ guile-config: $(srcdir)/guile-config.in $(top_builddir)/config.status mv guile-config.out guile-config chmod +x guile-config -CLEANFILES = guile-config +guild: $(srcdir)/guild.in $(top_builddir)/config.status + guile="@bindir@/`echo guile | $(SED) -e '$(program_transform_name)'`" ; \ + cat $(srcdir)/guild.in \ + | $(SED) -e "s,@installed_guile@,$$guile,g" \ + -e "s,[@]PACKAGE_NAME[@],$(PACKAGE_NAME),g" \ + -e "s,[@]PACKAGE_BUGREPORT[@],$(PACKAGE_BUGREPORT),g" \ + > "$@.out" + chmod +x "$@.out" + mv "$@.out" "$@" + +CLEANFILES = guile-config guild diff --git a/meta/guild.in b/meta/guild.in index d501a0daf..a68e0ff95 100755 --- a/meta/guild.in +++ b/meta/guild.in @@ -1,14 +1,12 @@ #!/bin/sh # -*- scheme -*- -prefix="@prefix@" -exec_prefix="@exec_prefix@" -exec ${GUILE:-@bindir@/@guile_program_name@} $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@" +exec ${GUILE:-@installed_guile@} $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@" !# ;;;; guild --- running scripts bundled with Guile ;;;; Andy Wingo --- April 2009 ;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 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 -- cgit v1.2.3 From fd584ec6707ae5b6e7b07fe19443b513fb0ba62b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 24 Apr 2014 23:46:20 +0200 Subject: build: Clean up rules for meta/{guild,guile-config}. * meta/Makefile.am (guile-config, guild): Avoid useless 'cat' invocation'. Quote all occurrences of '@'. Suggested by Eric Blake . --- meta/Makefile.am | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/meta/Makefile.am b/meta/Makefile.am index 102b7974d..57644bcd4 100644 --- a/meta/Makefile.am +++ b/meta/Makefile.am @@ -46,21 +46,21 @@ aclocal_DATA = guile.m4 guile-config: $(srcdir)/guile-config.in $(top_builddir)/config.status guile="@bindir@/`echo guile | $(SED) -e '$(program_transform_name)'`" ; \ - cat $(srcdir)/guile-config.in \ - | $(SED) -e "s,@pkgconfigdir@,$(pkgconfigdir),g" \ - -e "s,@""PKG_CONFIG@,$(PKG_CONFIG),g" \ - -e "s,@installed_guile@,$$guile,g" \ - > guile-config.out - mv guile-config.out guile-config - chmod +x guile-config + $(SED) -e "s,[@]pkgconfigdir[@],$(pkgconfigdir),g" \ + -e "s,[@]PKG_CONFIG[@],$(PKG_CONFIG),g" \ + -e "s,[@]installed_guile[@],$$guile,g" \ + < "$(srcdir)/guile-config.in" \ + > "$@.out" + chmod +x "$@.out" + mv "$@.out" "$@" guild: $(srcdir)/guild.in $(top_builddir)/config.status guile="@bindir@/`echo guile | $(SED) -e '$(program_transform_name)'`" ; \ - cat $(srcdir)/guild.in \ - | $(SED) -e "s,@installed_guile@,$$guile,g" \ - -e "s,[@]PACKAGE_NAME[@],$(PACKAGE_NAME),g" \ - -e "s,[@]PACKAGE_BUGREPORT[@],$(PACKAGE_BUGREPORT),g" \ - > "$@.out" + $(SED) -e "s,[@]installed_guile[@],$$guile,g" \ + -e "s,[@]PACKAGE_NAME[@],$(PACKAGE_NAME),g" \ + -e "s,[@]PACKAGE_BUGREPORT[@],$(PACKAGE_BUGREPORT),g" \ + < "$(srcdir)/guild.in" \ + > "$@.out" chmod +x "$@.out" mv "$@.out" "$@" -- cgit v1.2.3 From 4755604501948008849dcc9e114e5c84f355624d Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 24 Apr 2014 17:55:47 -0400 Subject: print: avoid triggering deprecation warnings when printing weak vectors. * libguile/print.c (iprin1): Use 'scm_c_weak_vector_ref' to access elements of weak vectors. --- libguile/print.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index 7e27f7670..122e03549 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -752,7 +752,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) `SIMPLE_VECTOR_REF ()' macro. */ for (i = 0; i < last; ++i) { - scm_iprin1 (scm_c_vector_ref (exp, i), + scm_iprin1 (scm_c_weak_vector_ref (exp, i), port, pstate); scm_putc (' ', port); } @@ -769,7 +769,10 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) if (i == last) { /* CHECK_INTS; */ - scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate); + scm_iprin1 (SCM_I_WVECTP (exp) + ? scm_c_weak_vector_ref (exp, i) + : SCM_SIMPLE_VECTOR_REF (exp, i), + port, pstate); } if (cutp) scm_puts (" ...", port); -- cgit v1.2.3 From e0da53b4fe4abee2cdcd97fe46eeefcaab1da631 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 24 Apr 2014 17:57:19 -0400 Subject: Support weak vectors, arrays, and bitvectors in (system base types). * module/system/base/types.scm (%tc7-wvect, %tc7-array, %tc7-bitvector): New variables. (cell->object): Add cases for weak vectors, arrays, and bitvectors. --- module/system/base/types.scm | 9 +++++++++ test-suite/tests/types.test | 8 ++++++++ 2 files changed, 17 insertions(+) diff --git a/module/system/base/types.scm b/module/system/base/types.scm index 4544a6ba0..de86bfc0b 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -242,6 +242,7 @@ the matching bits, possibly with bitwise operations to extract it from BITS." (define %tc3-struct 1) (define %tc7-symbol 5) (define %tc7-vector 13) +(define %tc7-wvect 15) (define %tc7-string 21) (define %tc7-number 23) (define %tc7-hashtable 29) @@ -255,6 +256,8 @@ the matching bits, possibly with bitwise operations to extract it from BITS." (define %tc7-vm-continuation 71) (define %tc7-bytevector 77) (define %tc7-program 79) +(define %tc7-array 85) +(define %tc7-bitvector 87) (define %tc7-port 125) (define %tc7-smob 127) @@ -447,6 +450,8 @@ using BACKEND." (bytevector->uint-list words (native-endianness) %word-size))) vector))) + (((_ & #x7f = %tc7-wvect)) + (inferior-object 'weak-vector address)) ; TODO: show elements ((((n << 8) || %tc7-fluid) init-value) (inferior-fluid n #f)) ; TODO: show current value (((_ & #x7f = %tc7-dynamic-state)) @@ -474,6 +479,10 @@ using BACKEND." (inferior-object 'vm address)) (((_ & #x7f = %tc7-vm-continuation)) (inferior-object 'vm-continuation address)) + (((_ & #x7f = %tc7-array)) + (inferior-object 'array address)) + (((_ & #x7f = %tc7-bitvector)) + (inferior-object 'bitvector address)) ((((smob-type << 8) || %tc7-smob) word1) (inferior-smob backend smob-type address)))))) diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test index e05ab11d7..191662d30 100644 --- a/test-suite/tests/types.test +++ b/test-suite/tests/types.test @@ -22,6 +22,7 @@ #:use-module (rnrs io ports) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 weak-vector) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (system foreign) @@ -102,6 +103,13 @@ ((open-input-string "hello") port (? integer?)) ((lambda () #t) program _) ((the-vm) vm _) + ((make-weak-vector 3 #t) weak-vector _) + ((make-hash-table) hash-table _) + ((make-weak-key-hash-table) hash-table _) + ((make-weak-value-hash-table) hash-table _) + ((make-doubly-weak-hash-table) hash-table _) + (#2((1 2 3) (4 5 6)) array _) + (#*00000110 bitvector _) ((expt 2 70) bignum _)) (pass-if "fluid" -- cgit v1.2.3