From 5e793ad8517d4036b115d2dbaaf105aad0414a20 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 16 May 2014 11:32:43 +0200 Subject: [PATCH 01/58] Silence GCC warning. * libguile/fports.c (scm_setvbuf): Initialize 'drained'. GCC 4.9 raises a "may be used uninitialized warning" for 'drained', because it can't tell that 'drained' is initialized anytime NDRAINED > 0. --- libguile/fports.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/fports.c b/libguile/fports.c index 5549bb124..29edc519c 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -155,7 +155,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, int cmode; long csize; size_t ndrained; - char *drained; + char *drained = NULL; scm_t_port *pt; scm_t_port_internal *pti; From c497bfb1f6e58c118aa35087104ab821dca5030c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 21 May 2014 15:34:22 +0200 Subject: [PATCH 02/58] tests: Add test for _IOLBF. * test-suite/tests/ports.test ("pipe, fdopen, and _IOLBF"): New test. --- test-suite/tests/ports.test | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index c1a185f17..d87257e04 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -623,6 +623,30 @@ (equal? in-string "Mommy, why does everybody have a bomb?\n"))) (delete-file filename)) +(pass-if-equal "pipe, fdopen, and _IOLBF" + "foo\nbar\n" + (let ((in+out (pipe)) + (pid (primitive-fork))) + (if (zero? pid) + (dynamic-wind + (const #t) + (lambda () + (close-port (car in+out)) + (let ((port (cdr in+out))) + (setvbuf port _IOLBF ) + ;; Strings containing '\n' or should be flushed; others + ;; should be kept in PORT's buffer. + (display "foo\n" port) + (display "bar\n" port) + (display "this will be kept in PORT's buffer" port))) + (lambda () + (primitive-_exit 0))) + (begin + (close-port (cdr in+out)) + (let ((str (read-all (car in+out)))) + (waitpid pid) + str))))) + ;;;; Void ports. These are so trivial we don't test them. From 0bb3f946e97424616c1a95f2372e5bc41e8f8174 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 23 May 2014 22:00:21 +0200 Subject: [PATCH 03/58] web: Keep the default size for the client's in-kernel receive buffer. Fixes . * module/web/client.scm (open-socket-for-uri): Remove call to 'setsockopt'. Contrary to what the comment said, its effect was to shrink the receive buffer from 124 KiB (the default size, per /proc/sys/net/core/rmem_default on Linux-based systems) to 12 KiB. --- module/web/client.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/module/web/client.scm b/module/web/client.scm index 3f6c45bfe..070b0c3d1 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -1,6 +1,6 @@ ;;; Web client -;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc. +;; Copyright (C) 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 @@ -92,8 +92,6 @@ ;; Buffer input and output on this port. (setvbuf s _IOFBF) - ;; Enlarge the receive buffer. - (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024)) ;; If we're using a proxy, make a note of that. (when http-proxy (set-http-proxy-port?! s #t)) s) From 1baa2159307c34683e8ede54f38f65010fc594b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 28 May 2014 19:26:45 +0200 Subject: [PATCH 04/58] Fix shrinking of contiguous bytevectors, as from 'get-bytevector-n'. Fixes . Reported by J Kalbhenn . * libguile/bytevectors.c (scm_c_shrink_bytevector): When BV is contiguous, add use of 'SCM_BYTEVECTOR_SET_CONTENTS'. --- libguile/bytevectors.c | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index be8b654cb..b21044038 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +/* Copyright (C) 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 @@ -315,10 +315,16 @@ scm_c_shrink_bytevector (SCM bv, size_t c_new_len) SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len); if (SCM_BYTEVECTOR_CONTIGUOUS_P (bv)) - new_bv = PTR2SCM (scm_gc_realloc (SCM2PTR (bv), - c_len + SCM_BYTEVECTOR_HEADER_BYTES, - c_new_len + SCM_BYTEVECTOR_HEADER_BYTES, - SCM_GC_BYTEVECTOR)); + { + signed char *c_bv; + + c_bv = scm_gc_realloc (SCM2PTR (bv), + c_len + SCM_BYTEVECTOR_HEADER_BYTES, + c_new_len + SCM_BYTEVECTOR_HEADER_BYTES, + SCM_GC_BYTEVECTOR); + new_bv = PTR2SCM (c_bv); + SCM_BYTEVECTOR_SET_CONTENTS (new_bv, c_bv + SCM_BYTEVECTOR_HEADER_BYTES); + } else { signed char *c_bv; From eb6ac6efcdb6fe72fdecb4aa7161e86d0e1d3282 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 28 May 2014 22:19:16 +0200 Subject: [PATCH 05/58] tests: Add test for . * test-suite/tests/r6rs-ports.test ("7.2.8 Binary Input")("http://bugs.gnu.org/17466"): New test. --- test-suite/tests/r6rs-ports.test | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 07c9f4465..dba803601 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -137,6 +137,26 @@ (close-port port) (get-bytevector-n port 3))) + (let ((expected (make-bytevector 20 (char->integer #\a)))) + (pass-if-equal "http://bugs.gnu.org/17466" + ;; is about a memory corruption + ;; whereas bytevector shrunk in 'get-bytevector-n' would keep + ;; referring to the previous (larger) bytevector. + expected + (let loop ((count 50)) + (if (zero? count) + expected + (let ((bv (call-with-input-string "aaaaaaaaaaaaaaaaaaaa" + (lambda (port) + (get-bytevector-n port 4096))))) + ;; Cause the 4 KiB bytevector initially created by + ;; 'get-bytevector-n' to be reclaimed. + (make-bytevector 4096) + + (if (equal? bv expected) + (loop (- count 1)) + bv)))))) + (pass-if "get-bytevector-n! [short]" (let* ((port (open-input-string "GNU Guile")) (bv (make-bytevector 4)) From a41b07a34f7309dccb2140ed924d7cd1c63268f9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 28 May 2014 23:00:20 +0200 Subject: [PATCH 06/58] rdelim: Speed up 'read-string' (aka. 'get-string-all'.) This yields a 20% improvement on the "read-string" benchmark. * module/ice-9/rdelim.scm (read-string): Rewrite as a 'case-lambda', with a tight loop around 'read-char', and without using 'read-string!'. * test-suite/tests/rdelim.test ("read-string")["longer than 100 chars, with limit"]: New test. * benchmark-suite/benchmarks/ports.bm ("rdelim")["read-string"]: New benchmark. --- benchmark-suite/benchmarks/ports.bm | 10 +++++-- module/ice-9/rdelim.scm | 44 ++++++++++++++++------------- test-suite/tests/rdelim.test | 10 +++++-- 3 files changed, 40 insertions(+), 24 deletions(-) diff --git a/benchmark-suite/benchmarks/ports.bm b/benchmark-suite/benchmarks/ports.bm index 630ece290..f4da2609a 100644 --- a/benchmark-suite/benchmarks/ports.bm +++ b/benchmark-suite/benchmarks/ports.bm @@ -1,6 +1,6 @@ ;;; ports.bm --- Port I/O. -*- mode: scheme; coding: utf-8; -*- ;;; -;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. +;;; Copyright (C) 2010, 2011, 2012, 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 @@ -89,4 +89,10 @@ (benchmark "read-line" 1000 (let ((port (with-fluids ((%default-port-encoding "UTF-8")) (open-input-string str)))) - (sequence (read-line port) 1000))))) + (sequence (read-line port) 1000)))) + + (let ((str (large-string "Hello, world.\n"))) + (benchmark "read-string" 200 + (let ((port (with-fluids ((%default-port-encoding "UTF-8")) + (open-input-string str)))) + (read-string port))))) diff --git a/module/ice-9/rdelim.scm b/module/ice-9/rdelim.scm index 32908cc4a..a406f4e55 100644 --- a/module/ice-9/rdelim.scm +++ b/module/ice-9/rdelim.scm @@ -1,7 +1,8 @@ ;;; installed-scm-file -;;;; Copyright (C) 1997, 1999, 2000, 2001, 2006, 2010, 2013 Free Software Foundation, Inc. -;;;; +;;;; Copyright (C) 1997, 1999, 2000, 2001, 2006, 2010, 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 @@ -148,26 +149,29 @@ left in the port." (lp (1+ n))))) (- n start)))) -(define* (read-string #:optional (port (current-input-port)) (count #f)) - "Read all of the characters out of PORT and return them as a string. +(define* read-string + (case-lambda* + "Read all of the characters out of PORT and return them as a string. If the COUNT argument is present, treat it as a limit to the number of characters to read. By default, there is no limit." - (check-arg (or (not count) (index? count)) "bad count" count) - (let loop ((substrings '()) - (total-chars 0) - (buf-size 100)) ; doubled each time through. - (let* ((buf (make-string (if count - (min buf-size (- count total-chars)) - buf-size))) - (nchars (read-string! buf port)) - (new-total (+ total-chars nchars))) - (cond - ((= nchars buf-size) - ;; buffer filled. - (loop (cons buf substrings) new-total (* buf-size 2))) - (else - (string-concatenate-reverse - (cons (substring buf 0 nchars) substrings))))))) + ((#:optional (port (current-input-port))) + ;; Fast path. + ;; This creates more garbage than using 'string-set!' as in + ;; 'read-string!', but currently that is faster nonetheless. + (let loop ((chars '())) + (let ((char (read-char port))) + (if (eof-object? char) + (list->string (reverse! chars)) + (loop (cons char chars)))))) + ((port count) + ;; Slower path. + (let loop ((chars '()) + (total 0)) + (let ((char (read-char port))) + (if (or (eof-object? char) (>= total count)) + (list->string (reverse chars)) + (loop (cons char chars) (+ 1 total)))))))) + ;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string ;;; from PORT. The return value depends on the value of HANDLE-DELIM, diff --git a/test-suite/tests/rdelim.test b/test-suite/tests/rdelim.test index 5cfe6460d..9083b7f62 100644 --- a/test-suite/tests/rdelim.test +++ b/test-suite/tests/rdelim.test @@ -1,7 +1,7 @@ ;;;; rdelim.test --- Delimited I/O. -*- mode: scheme; coding: utf-8; -*- ;;;; Ludovic Courtès ;;;; -;;;; Copyright (C) 2011, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 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 @@ -209,7 +209,13 @@ (let* ((s (string-concatenate (make-list 20 "hello, world!"))) (p (open-input-string s))) (and (string=? (read-string p) s) - (string=? (read-string p) ""))))) + (string=? (read-string p) "")))) + + (pass-if-equal "longer than 100 chars, with limit" + "hello, world!" + (let* ((s (string-concatenate (make-list 20 "hello, world!"))) + (p (open-input-string s))) + (read-string p 13)))) (with-test-prefix "read-string!" From a43fa1b70688b09a9eecac3c2ce8e9adea63bab6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 28 May 2014 23:06:45 +0200 Subject: [PATCH 07/58] Slightly simplify 'scm_open_process'. * libguile/posix.c (scm_open_process): Call 'scm_fdes_to_port' with the '0' flag, and remove 'scm_setvbuf' calls. --- libguile/posix.c | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 6a940e46f..1dcb5acbb 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1345,23 +1345,21 @@ scm_open_process (SCM mode, SCM prog, SCM args) SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F; /* There is no sense in catching errors on close(). */ - if (reading) + if (reading) { close (c2p[1]); - read_port = scm_fdes_to_port (c2p[0], "r", sym_read_pipe); - scm_setvbuf (read_port, scm_from_int (_IONBF), SCM_UNDEFINED); + read_port = scm_fdes_to_port (c2p[0], "r0", sym_read_pipe); } if (writing) { close (p2c[0]); - write_port = scm_fdes_to_port (p2c[1], "w", sym_write_pipe); - scm_setvbuf (write_port, scm_from_int (_IONBF), SCM_UNDEFINED); + write_port = scm_fdes_to_port (p2c[1], "w0", sym_write_pipe); } - + return scm_values (scm_list_3 (read_port, write_port, scm_from_int (pid))); } - + /* The child. */ if (reading) close (c2p[0]); From 12c6a47773041ff5d0a3553421d2f358d9e479a9 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 1 Jun 2014 19:08:25 -0400 Subject: [PATCH 08/58] Mark system async functions as SCM_API. Fixes . Reported and fixed by Chris Vine . * libguile/async.h (scm_c_call_with_blocked_asyncs) (scm_c_call_with_unblocked_asyncs, scm_dynwind_block_asyncs) (scm_dynwind_unblock_asyncs): Mark as SCM_API. * THANKS: Add Chris Vine to fixes section. --- THANKS | 1 + libguile/async.h | 11 ++++++----- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/THANKS b/THANKS index d34b951e2..e6268730b 100644 --- a/THANKS +++ b/THANKS @@ -182,6 +182,7 @@ For fixes or providing information which led to a fix: Aaron VanDevender Sjoerd Van Leent Andreas Vögele + Chris Vine Michael Talbot-Wilson Michael Tuexen Xin Wang diff --git a/libguile/async.h b/libguile/async.h index b3503de9a..3da808e10 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -3,7 +3,8 @@ #ifndef SCM_ASYNC_H #define SCM_ASYNC_H -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2008, 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 @@ -44,10 +45,10 @@ SCM_API SCM scm_run_asyncs (SCM list_of_a); SCM_API SCM scm_noop (SCM args); SCM_API SCM scm_call_with_blocked_asyncs (SCM proc); SCM_API SCM scm_call_with_unblocked_asyncs (SCM proc); -void *scm_c_call_with_blocked_asyncs (void *(*p) (void *d), void *d); -void *scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d); -void scm_dynwind_block_asyncs (void); -void scm_dynwind_unblock_asyncs (void); +SCM_API void *scm_c_call_with_blocked_asyncs (void *(*p) (void *d), void *d); +SCM_API void *scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d); +SCM_API void scm_dynwind_block_asyncs (void); +SCM_API void scm_dynwind_unblock_asyncs (void); /* Critical sections */ From a5186f506f69ef8a8accd234ca434efd13f302c9 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 18 Apr 2014 15:04:12 -0400 Subject: [PATCH 09/58] SRFI-1 'length+' raises an error unless passed a proper or circular list. Fixes . * libguile/srfi-1.c (scm_srfi1_length_plus): Rewrite to raise an error unless passed a proper or circular list, based on code from 'scm_ilength'. * test-suite/tests/srfi-1.test (length+): Add tests. --- libguile/srfi-1.c | 32 ++++++++++++++++++++++++++++---- test-suite/tests/srfi-1.test | 6 +++++- 2 files changed, 33 insertions(+), 5 deletions(-) diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index 54c7e2aa3..fcbf80694 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -1,7 +1,7 @@ /* srfi-1.c --- SRFI-1 procedures for Guile * - * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006, - * 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + * Copyright (C) 1995-1997, 2000-2003, 2005, 2006, 2008-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 @@ -614,8 +614,32 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0, "circular.") #define FUNC_NAME s_scm_srfi1_length_plus { - long len = scm_ilength (lst); - return (len >= 0 ? SCM_I_MAKINUM (len) : SCM_BOOL_F); + size_t i = 0; + SCM tortoise = lst; + SCM hare = lst; + + do + { + if (SCM_NULL_OR_NIL_P (hare)) + return scm_from_size_t (i); + if (!scm_is_pair (hare)) + scm_wrong_type_arg_msg (FUNC_NAME, 1, lst, "proper or circular list"); + hare = SCM_CDR (hare); + i++; + if (SCM_NULL_OR_NIL_P (hare)) + return scm_from_size_t (i); + if (!scm_is_pair (hare)) + scm_wrong_type_arg_msg (FUNC_NAME, 1, lst, "proper or circular list"); + hare = SCM_CDR (hare); + i++; + /* For every two steps the hare takes, the tortoise takes one. */ + tortoise = SCM_CDR(tortoise); + } + while (!scm_is_eq (hare, tortoise)); + + /* If the tortoise ever catches the hare, then the list must contain + a cycle. */ + return SCM_BOOL_F; } #undef FUNC_NAME diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index d40f8e1c2..bce0e86da 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -1,6 +1,6 @@ ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*- ;;;; -;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright 2003-2006, 2008-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 @@ -1329,6 +1329,10 @@ (length+)) (pass-if-exception "too many args" exception:wrong-num-args (length+ 123 456)) + (pass-if-exception "not a pair" exception:wrong-type-arg + (length+ 'x)) + (pass-if-exception "improper list" exception:wrong-type-arg + (length+ '(x y . z))) (pass-if (= 0 (length+ '()))) (pass-if (= 1 (length+ '(x)))) (pass-if (= 2 (length+ '(x y)))) From 2da97f1c7c0748509180308d9e6a817bc49172e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 3 Jun 2014 14:58:55 +0200 Subject: [PATCH 10/58] 'guild compile' doesn't leave temporary files behind it. * module/scripts/compile.scm (compile): Add 'sigaction' call. * test-suite/standalone/test-guild-compile: New file. * test-suite/standalone/Makefile.am (check_SCRIPTS, TESTS): Add it. --- module/scripts/compile.scm | 10 +++++- test-suite/standalone/Makefile.am | 3 ++ test-suite/standalone/test-guild-compile | 42 ++++++++++++++++++++++++ 3 files changed, 54 insertions(+), 1 deletion(-) create mode 100755 test-suite/standalone/test-guild-compile diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 20db94463..0a2ca4d23 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -1,6 +1,6 @@ ;;; Compile --- Command-line Guile Scheme compiler -*- coding: iso-8859-1 -*- -;; Copyright 2005,2008,2009,2010,2011 Free Software Foundation, Inc. +;; Copyright 2005, 2008, 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 Lesser General Public License @@ -176,6 +176,14 @@ Report bugs to <~A>.~%" (fail "`-o' option can only be specified " "when compiling a single file")) + ;; Install a SIGINT handler. As a side effect, this gives unwind + ;; handlers an opportunity to run upon SIGINT; this includes that of + ;; 'call-with-output-file/atomic', called by 'compile-file', which + ;; removes the temporary output file. + (sigaction SIGINT + (lambda args + (fail "interrupted by the user"))) + (for-each (lambda (file) (format #t "wrote `~A'\n" (with-fluids ((*current-warning-prefix* "")) diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index 9360f6903..6f676ebc8 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -93,6 +93,9 @@ check_SCRIPTS += test-language TESTS += test-language EXTRA_DIST += test-language.el test-language.js +check_SCRIPTS += test-guild-compile +TESTS += test-guild-compile + # test-num2integral test_num2integral_SOURCES = test-num2integral.c test_num2integral_CFLAGS = ${test_cflags} diff --git a/test-suite/standalone/test-guild-compile b/test-suite/standalone/test-guild-compile new file mode 100755 index 000000000..05d45ce35 --- /dev/null +++ b/test-suite/standalone/test-guild-compile @@ -0,0 +1,42 @@ +#!/bin/sh +# +# This -*- sh -*- script tests whether 'guild compile' leaves traces +# behind it upon SIGINT. + +source="t-guild-compile-$$" +target="$source.go" + +trap 'rm -f "$source" "$target"' EXIT + +cat > "$source"<&2 + rm "$target"* + kill "$pid" + exit 1 + fi +done + +if test -f "$target" +then + echo "error: '$target' produced" >&2 + exit 1 +fi From 1ea8954814d124b995f2296bc6aec92adb566bc1 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 4 Jun 2014 19:30:16 -0400 Subject: [PATCH 11/58] Avoid quadratic expansion time in 'and' and 'or' macros. Fixes . Reported by David Kastrup . * module/ice-9/boot-9.scm (and, or): Use dotted tail instead of ellipsis in patterns. --- module/ice-9/boot-9.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 42d7d7837..c6d4be111 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1,8 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- -;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, -;;;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 -;;;; Free Software Foundation, Inc. +;;;; Copyright (C) 1995-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 @@ -409,13 +407,15 @@ If there is no handler at all, Guile prints an error and then exits." (syntax-rules () ((_) #t) ((_ x) x) - ((_ x y ...) (if x (and y ...) #f)))) + ;; Avoid ellipsis, which would lead to quadratic expansion time. + ((_ x . y) (if x (and . y) #f)))) (define-syntax or (syntax-rules () ((_) #f) ((_ x) x) - ((_ x y ...) (let ((t x)) (if t t (or y ...)))))) + ;; Avoid ellipsis, which would lead to quadratic expansion time. + ((_ x . y) (let ((t x)) (if t t (or . y)))))) (include-from-path "ice-9/quasisyntax") From 4afca1a0662323ed8760c75d84c3aadc64b72908 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 4 Jun 2014 20:40:23 -0400 Subject: [PATCH 12/58] test-guild-compile: Increase sleep time before sending SIGINT. * test-suite/standalone/test-guild-compile: Increase sleep time before sending SIGINT, for slow machines. --- test-suite/standalone/test-guild-compile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/standalone/test-guild-compile b/test-suite/standalone/test-guild-compile index 05d45ce35..525ecc6e0 100755 --- a/test-suite/standalone/test-guild-compile +++ b/test-suite/standalone/test-guild-compile @@ -18,7 +18,7 @@ guild compile -o "$target" "$source" & pid="$!" # Send SIGINT. -sleep 1 && kill -INT "$pid" +sleep 2 && kill -INT "$pid" # Wait for 'guild compile' to terminate. sleep 2 From fc8a90043bb8dc876cf638d9959348883c748fe3 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 4 Jun 2014 20:42:21 -0400 Subject: [PATCH 13/58] Optimize scm_ilength and 'length+'. * libguile/list.c (scm_ilength): Test for SCM_NULL_OR_NIL_P only after testing scm_is_pair. Conform to GNU coding standards. * libguile/srfi-1.c (scm_srfi1_length_plus): Ditto. --- libguile/list.c | 31 ++++++++++++++++--------------- libguile/srfi-1.c | 22 +++++++++++++++------- 2 files changed, 31 insertions(+), 22 deletions(-) diff --git a/libguile/list.c b/libguile/list.c index 01f23c0f0..669f566d6 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -1,5 +1,5 @@ -/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008,2009,2010,2011 - * Free Software Foundation, Inc. +/* Copyright (C) 1995-1997, 2000, 2001, 2003, 2004, 2008-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 @@ -179,24 +179,25 @@ SCM_DEFINE (scm_list_p, "list?", 1, 0, 0, long" lists (i.e. lists with cycles in their cdrs), and returns -1 if it does find one. */ long -scm_ilength(SCM sx) +scm_ilength (SCM sx) { long i = 0; SCM tortoise = sx; SCM hare = sx; - do { - if (SCM_NULL_OR_NIL_P(hare)) return i; - if (!scm_is_pair (hare)) return -1; - hare = SCM_CDR(hare); - i++; - if (SCM_NULL_OR_NIL_P(hare)) return i; - if (!scm_is_pair (hare)) return -1; - hare = SCM_CDR(hare); - i++; - /* For every two steps the hare takes, the tortoise takes one. */ - tortoise = SCM_CDR(tortoise); - } + do + { + if (!scm_is_pair (hare)) + return SCM_NULL_OR_NIL_P (hare) ? i : -1; + hare = SCM_CDR (hare); + i++; + if (!scm_is_pair (hare)) + return SCM_NULL_OR_NIL_P (hare) ? i : -1; + hare = SCM_CDR (hare); + i++; + /* For every two steps the hare takes, the tortoise takes one. */ + tortoise = SCM_CDR (tortoise); + } while (!scm_is_eq (hare, tortoise)); /* If the tortoise ever catches the hare, then the list must contain diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index fcbf80694..c0b7035fc 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -620,20 +620,28 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0, do { - if (SCM_NULL_OR_NIL_P (hare)) - return scm_from_size_t (i); if (!scm_is_pair (hare)) - scm_wrong_type_arg_msg (FUNC_NAME, 1, lst, "proper or circular list"); + { + if (SCM_NULL_OR_NIL_P (hare)) + return scm_from_size_t (i); + else + scm_wrong_type_arg_msg (FUNC_NAME, 1, lst, + "proper or circular list"); + } hare = SCM_CDR (hare); i++; - if (SCM_NULL_OR_NIL_P (hare)) - return scm_from_size_t (i); if (!scm_is_pair (hare)) - scm_wrong_type_arg_msg (FUNC_NAME, 1, lst, "proper or circular list"); + { + if (SCM_NULL_OR_NIL_P (hare)) + return scm_from_size_t (i); + else + scm_wrong_type_arg_msg (FUNC_NAME, 1, lst, + "proper or circular list"); + } hare = SCM_CDR (hare); i++; /* For every two steps the hare takes, the tortoise takes one. */ - tortoise = SCM_CDR(tortoise); + tortoise = SCM_CDR (tortoise); } while (!scm_is_eq (hare, tortoise)); From d86a0631585ba887cd8635001f3a2c8d000c6517 Mon Sep 17 00:00:00 2001 From: Dmitry Bogatov Date: Wed, 4 Jun 2014 20:49:28 -0400 Subject: [PATCH 14/58] Fix typo in `transform-string' doc. * doc/ref/texinfo.texi: Fix single typo. Signed-off-by: Dmitry Bogatov --- doc/ref/texinfo.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/texinfo.texi b/doc/ref/texinfo.texi index ec0686388..5006fd427 100644 --- a/doc/ref/texinfo.texi +++ b/doc/ref/texinfo.texi @@ -287,7 +287,7 @@ as an argument, and the returned value is sent to the output string via @samp{display}. If @var{replace} is anything else, it is sent through the output string via @samp{display}. -Note that te replacement for the matched characters does not need to be +Note that the replacement for the matched characters does not need to be a single character. That is what differentiates this function from @samp{string-map}, and what makes it useful for applications such as converting @samp{#\&} to @samp{"&"} in web page text. Some other From 43191a31a5f15729acbde3fa58f750021977a9f9 Mon Sep 17 00:00:00 2001 From: Taylan Ulrich B Date: Thu, 5 Jun 2014 19:27:53 +0200 Subject: [PATCH 15/58] R6RS library documentation fix * doc/ref/api-modules.texi (R6RS Libraries): Move 'export' before 'import' in the example library form, as required by R6RS. --- doc/ref/api-modules.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi index 286a37d7e..0f54e01ab 100644 --- a/doc/ref/api-modules.texi +++ b/doc/ref/api-modules.texi @@ -584,8 +584,8 @@ expression: @lisp (library (mylib (1 2)) - (import (otherlib (3))) - (export mybinding)) + (export mybinding) + (import (otherlib (3)))) @end lisp is equivalent to the module definition: From 82b8cfa40cbaea1ef2b8053af574c6d84f2705bc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 11 Jun 2014 14:35:26 +0200 Subject: [PATCH 16/58] tests: Use NUL instead of /dev/null on MinGW. Reported by Eli Zaretskii . * test-suite/test-suite/lib.scm (%null-device): New variable. * test-suite/tests/c-api.test (egrep): Use %NULL-DEVICE instead of /dev/null. * test-suite/tests/popen.test ("open-input-pipe")["no duplicate"]: Likewise. --- test-suite/test-suite/lib.scm | 13 ++++++++++++- test-suite/tests/c-api.test | 5 +++-- test-suite/tests/popen.test | 6 ++++-- 3 files changed, 19 insertions(+), 5 deletions(-) diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm index e25df7891..5628ae02a 100644 --- a/test-suite/test-suite/lib.scm +++ b/test-suite/test-suite/lib.scm @@ -1,6 +1,6 @@ ;;;; test-suite/lib.scm --- generic support for testing ;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010, -;;;; 2011, 2012, 2013 Free Software Foundation, Inc. +;;;; 2011, 2012, 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 @@ -63,6 +63,9 @@ ;; Using a given locale with-locale with-locale* with-latin1-locale with-latin1-locale* + ;; The bit bucket. + %null-device + ;; Reporting results in various ways. register-reporter unregister-reporter reporter-registered? make-count-reporter print-counts @@ -571,6 +574,14 @@ ((_ body ...) (with-latin1-locale* (lambda () body ...))))) +(define %null-device + ;; On Windows (MinGW), /dev/null does not exist and we must instead + ;; use NUL. Note that file system procedures automatically translate + ;; /dev/null, so this variable is only useful for shell snippets. + (if (file-exists? "/dev/null") + "/dev/null" + "NUL")) + ;;;; REPORTERS ;;;; diff --git a/test-suite/tests/c-api.test b/test-suite/tests/c-api.test index 9a2108e69..5ce033f8d 100644 --- a/test-suite/tests/c-api.test +++ b/test-suite/tests/c-api.test @@ -1,7 +1,7 @@ ;;;; c-api.test --- complementary test suite for the c-api -*- scheme -*- ;;;; MDJ 990915 ;;;; -;;;; Copyright (C) 1999, 2006, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2006, 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 @@ -22,7 +22,8 @@ (define srcdir (cdr (assq 'srcdir %guile-build-info))) (define (egrep string filename) - (zero? (system (string-append "egrep '" string "' " filename " >/dev/null")))) + (zero? (system (string-append "egrep '" string "' " filename + " >" %null-device)))) (define (seek-offset-test dirname) (let ((dir (opendir dirname))) diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test index 2818be01b..27e15dcad 100644 --- a/test-suite/tests/popen.test +++ b/test-suite/tests/popen.test @@ -1,6 +1,6 @@ ;;;; popen.test --- exercise ice-9/popen.scm -*- scheme -*- ;;;; -;;;; Copyright 2003, 2006, 2010, 2011, 2013 Free Software Foundation, Inc. +;;;; Copyright 2003, 2006, 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 @@ -109,7 +109,9 @@ (with-input-from-port (car p2c) (lambda () (open-input-pipe - "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; read REPLY"))))))) + (format #f "exec 1>~a; echo closed 1>&2; \ +exec 2>~a; read REPLY" + %null-device %null-device)))))))) (close-port (cdr c2p)) ;; write side (let ((result (eof-object? (read-char port)))) (display "hello!\n" (cdr p2c)) From c84f25bccebb1ba557ace597370d88bc8f5382e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 11 Jun 2014 14:54:21 +0200 Subject: [PATCH 17/58] i18n: Ignore LC_MESSAGES on MinGW. * libguile/locale-categories.h (MESSAGES): Add condition on !(defined(LC_MAX) && LC_MESSAGES > LC_MAX). * test-suite/tests/i18n.test ("locale objects")["make-locale (2 args, list)", "make-locale (3 args)", "locale?"]: Use LC_NUMERIC or LC_TIME instead of LC_MESSAGES. Co-authored-by: Eli Zaretskii --- libguile/locale-categories.h | 8 +++++--- test-suite/tests/i18n.test | 8 ++++---- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/libguile/locale-categories.h b/libguile/locale-categories.h index 26b030dc5..fb5ac1081 100644 --- a/libguile/locale-categories.h +++ b/libguile/locale-categories.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 2006, 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,8 +23,10 @@ SCM_DEFINE_LOCALE_CATEGORY (COLLATE) SCM_DEFINE_LOCALE_CATEGORY (CTYPE) -#ifdef LC_MESSAGES -/* MinGW doesn't have `LC_MESSAGES'. */ +#if defined(LC_MESSAGES) && !(defined(LC_MAX) && LC_MESSAGES > LC_MAX) +/* MinGW doesn't have `LC_MESSAGES'. libintl.h might define + `LC_MESSAGES' for MinGW to an arbitrary large value which we cannot + use in a call to `setlocale'. */ SCM_DEFINE_LOCALE_CATEGORY (MESSAGES) #endif diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index b980cdcdb..68ae38c23 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -1,7 +1,7 @@ ;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*- ;;;; ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012, -;;;; 2013 Free Software Foundation, Inc. +;;;; 2013, 2014 Free Software Foundation, Inc. ;;;; Ludovic Courtès ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -38,18 +38,18 @@ (not (not (make-locale LC_ALL "C")))) (pass-if "make-locale (2 args, list)" - (not (not (make-locale (list LC_COLLATE LC_MESSAGES) "C")))) + (not (not (make-locale (list LC_COLLATE LC_NUMERIC) "C")))) (pass-if "make-locale (3 args)" (not (not (make-locale (list LC_COLLATE) "C" - (make-locale (list LC_MESSAGES) "C"))))) + (make-locale (list LC_NUMERIC) "C"))))) (pass-if-exception "make-locale with unknown locale" exception:locale-error (make-locale LC_ALL "does-not-exist")) (pass-if "locale?" (and (locale? (make-locale (list LC_ALL) "C")) - (locale? (make-locale (list LC_MESSAGES LC_NUMERIC) "C" + (locale? (make-locale (list LC_TIME LC_NUMERIC) "C" (make-locale (list LC_CTYPE) "C"))))) (pass-if "%global-locale" From 700f6cd86b939789e19fd325f3ad2862eac5975e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 11 Jun 2014 15:03:31 +0200 Subject: [PATCH 18/58] i18n: Adjust tests for Windows. * test-suite/tests/i18n.test (mingw?): New variable. (%french-locale-name, %french-utf8-locale-name, %turkish-utf8-locale-name, %german-utf8-locale-name, %greek-utf8-locale-name): Add name of corresponding Windows codepage, when MINGW? is true. (under-turkish-utf8-locale-or-unresolved): Add exception for "mingw32". Co-authored-by: Eli Zaretskii --- test-suite/tests/i18n.test | 37 +++++++++++++++++++++++++++---------- 1 file changed, 27 insertions(+), 10 deletions(-) diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 68ae38c23..c63e3ac5b 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -81,20 +81,36 @@ (make-locale (list LC_COLLATE) "C"))))) +(define mingw? + (string-contains %host-type "-mingw32")) + (define %french-locale-name - "fr_FR.ISO-8859-1") + (if mingw? + "fra_FRA.850" + "fr_FR.ISO-8859-1")) + +;; What we really want for the following locales is that they be Unicode +;; capable, not necessarily UTF-8, which Windows does not provide. (define %french-utf8-locale-name - "fr_FR.UTF-8") + (if mingw? + "fra_FRA.1252" + "fr_FR.UTF-8")) (define %turkish-utf8-locale-name - "tr_TR.UTF-8") + (if mingw? + "tur_TRK.1254" + "tr_TR.UTF-8")) (define %german-utf8-locale-name - "de_DE.UTF-8") + (if mingw? + "deu_DEU.1252" + "de_DE.UTF-8")) (define %greek-utf8-locale-name - "el_GR.UTF-8") + (if mingw? + "grc_ELL.1253" + "el_GR.UTF-8")) (define %american-english-locale-name "en_US") @@ -148,13 +164,14 @@ (under-locale-or-unresolved %french-utf8-locale thunk)) (define (under-turkish-utf8-locale-or-unresolved thunk) - ;; FreeBSD 8.2 and 9.1, Solaris 2.10, and Darwin 8.11.0 have a broken - ;; tr_TR locale where `i' is mapped to uppercase `I' instead of `İ', - ;; so disable tests on that platform. + ;; FreeBSD 8.2 and 9.1, Solaris 2.10, Darwin 8.11.0, and MinGW have + ;; a broken tr_TR locale where `i' is mapped to uppercase `I' + ;; instead of `İ', so disable tests on that platform. (if (or (string-contains %host-type "freebsd8") (string-contains %host-type "freebsd9") (string-contains %host-type "solaris2.10") - (string-contains %host-type "darwin8")) + (string-contains %host-type "darwin8") + (string-contains %host-type "mingw32")) (throw 'unresolved) (under-locale-or-unresolved %turkish-utf8-locale thunk))) @@ -192,7 +209,7 @@ ;; strings. (dynamic-wind (lambda () - (setlocale LC_ALL "fr_FR.UTF-8")) + (setlocale LC_ALL %french-utf8-locale-name)) (lambda () (string-locale-ci=? "œuf" "ŒUF")) (lambda () From f0893308461d9586d4fd00d78fd7999a660058ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 12 Jun 2014 23:19:29 +0200 Subject: [PATCH 19/58] tests: Improve lack-of-/dev/null detection. Suggested by Eli Zaretskii . * test-suite/test-suite/lib.scm (%null-device): Test for Windows based by checking for a drive letter in the current directory name. --- test-suite/test-suite/lib.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm index 5628ae02a..54360b361 100644 --- a/test-suite/test-suite/lib.scm +++ b/test-suite/test-suite/lib.scm @@ -578,9 +578,12 @@ ;; On Windows (MinGW), /dev/null does not exist and we must instead ;; use NUL. Note that file system procedures automatically translate ;; /dev/null, so this variable is only useful for shell snippets. - (if (file-exists? "/dev/null") - "/dev/null" - "NUL")) + + ;; Test for Windowsness by checking whether the current directory name + ;; starts with a drive letter. + (if (string-match "^[a-zA-Z]:[/\\]" (getcwd)) + "NUL" + "/dev/null")) ;;;; REPORTERS From c7161ee334c20a81cb50512b2d6ae0aebf34ede9 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 22 Jun 2014 19:11:30 +0300 Subject: [PATCH 20/58] Fix compilation of scm_nl_langinfo when some nl_langinfo items are missing. * i18n.c (scm_nl_langinfo): Don't assume that both INT_* and the corresponding non-INT_* items are always either all defined or all undefined. --- libguile/i18n.c | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/libguile/i18n.c b/libguile/i18n.c index 0f607f331..e38e5602e 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1580,9 +1580,13 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, } #endif -#if (defined FRAC_DIGITS) && (defined INT_FRAC_DIGITS) +#if defined FRAC_DIGITS || defined INT_FRAC_DIGITS +#ifdef FRAC_DIGITS case FRAC_DIGITS: +#endif +#ifdef INT_FRAC_DIGITS case INT_FRAC_DIGITS: +#endif /* This is to be interpreted as a single integer. */ if (*c_result == CHAR_MAX) /* Unspecified. */ @@ -1594,12 +1598,18 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, break; #endif -#if (defined P_CS_PRECEDES) && (defined INT_N_CS_PRECEDES) +#if defined P_CS_PRECEDES || defined N_CS_PRECEDES || \ + defined INT_P_CS_PRECEDES || defined INT_N_CS_PRECEDES || \ + defined P_SEP_BY_SPACE || defined N_SEP_BY_SPACE +#ifdef P_CS_PRECEDES case P_CS_PRECEDES: case N_CS_PRECEDES: +#endif +#ifdef INT_N_CS_PRECEDES case INT_P_CS_PRECEDES: case INT_N_CS_PRECEDES: -#if (defined P_SEP_BY_SPACE) && (defined N_SEP_BY_SPACE) +#endif +#ifdef P_SEP_BY_SPACE case P_SEP_BY_SPACE: case N_SEP_BY_SPACE: #endif @@ -1610,11 +1620,16 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, break; #endif -#if (defined P_SIGN_POSN) && (defined INT_N_SIGN_POSN) +#if defined P_SIGN_POSN || defined N_SIGN_POSN || \ + defined INT_P_SIGN_POSN || defined INT_N_SIGN_POSN +#ifdef P_SIGN_POSN case P_SIGN_POSN: case N_SIGN_POSN: +#endif +#ifdef INT_P_SIGN_POSN case INT_P_SIGN_POSN: case INT_N_SIGN_POSN: +#endif /* See `(libc) Sign of Money Amount' for the interpretation of the return value here. */ switch (*c_result) From 0d77e062dc70ed10cfcedf1e6080287f8be20b1b Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 2 Jul 2014 18:28:06 +0300 Subject: [PATCH 21/58] Fix deletion of ports.test test file on MS-Windows. * test-suite/tests/ports.test ("fdes->port", "seek") ("truncate-file"): Close every file and port we open, to avoid failure to delete the test file on MS-Windows when the test is completed. --- test-suite/tests/ports.test | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index d87257e04..e7acd6332 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -1270,9 +1270,10 @@ (with-test-prefix "fdes->port" (pass-if "fdes->ports finds port" - (let ((port (open-file (test-file) "w"))) - - (not (not (memq port (fdes->ports (port->fdes port)))))))) + (let* ((port (open-file (test-file) "w")) + (res (not (not (memq port (fdes->ports (port->fdes port))))))) + (close-port port) + res))) ;;; ;;; seek @@ -1289,7 +1290,9 @@ (let ((port (open-file (test-file) "r"))) (read-char port) (seek port 2 SEEK_CUR) - (eqv? #\d (read-char port)))) + (let ((res (eqv? #\d (read-char port)))) + (close-port port) + res))) (pass-if "SEEK_SET" (call-with-output-file (test-file) @@ -1298,7 +1301,9 @@ (let ((port (open-file (test-file) "r"))) (read-char port) (seek port 3 SEEK_SET) - (eqv? #\d (read-char port)))) + (let ((res (eqv? #\d (read-char port)))) + (close-port port) + res))) (pass-if "SEEK_END" (call-with-output-file (test-file) @@ -1307,7 +1312,9 @@ (let ((port (open-file (test-file) "r"))) (read-char port) (seek port -2 SEEK_END) - (eqv? #\d (read-char port)))))) + (let ((res (eqv? #\d (read-char port)))) + (close-port port) + res))))) ;;; ;;; truncate-file @@ -1370,7 +1377,8 @@ (lambda (port) (display "hello" port))) (let ((port (open-file (test-file) "r+"))) - (truncate-file port 1)) + (truncate-file port 1) + (close-port port)) (eqv? 1 (stat:size (stat (test-file))))) (pass-if "shorten to current pos" @@ -1379,7 +1387,8 @@ (display "hello" port))) (let ((port (open-file (test-file) "r+"))) (read-char port) - (truncate-file port)) + (truncate-file port) + (close-port port)) (eqv? 1 (stat:size (stat (test-file))))))) From 4698a11cbdb057953cf4e02126c701d875cc1f42 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 2 Jul 2014 18:38:28 +0300 Subject: [PATCH 22/58] Make 'system*' available on MS-Windows. * libguile/simpos.c (scm_system_star) [!HAVE_FORK]: An implementation of 'system*' for MS-Windows, which doesn't have 'fork', but can use 'spawnvp' in this case. --- libguile/simpos.c | 32 ++++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/libguile/simpos.c b/libguile/simpos.c index 6b3f51bb2..c0fbd79c5 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -45,6 +45,10 @@ # include #endif +#ifdef __MINGW32__ +# include /* for spawnvp and friends */ +#endif + #include "posix.h" @@ -86,8 +90,6 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, #ifdef HAVE_SYSTEM -#ifdef HAVE_WAITPID - SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, (SCM args), @@ -115,11 +117,18 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, if (scm_is_pair (args)) { SCM oldint; - SCM oldquit; SCM sig_ign; SCM sigint; + /* SIGQUIT is undefined on MS-Windows. */ +#ifdef SIGQUIT + SCM oldquit; SCM sigquit; +#endif +#ifdef HAVE_FORK int pid; +#else + int status; +#endif char **execargv; /* allocate before fork */ @@ -128,10 +137,13 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, /* make sure the child can't kill us (as per normal system call) */ sig_ign = scm_from_ulong ((unsigned long) SIG_IGN); sigint = scm_from_int (SIGINT); - sigquit = scm_from_int (SIGQUIT); oldint = scm_sigaction (sigint, sig_ign, SCM_UNDEFINED); +#ifdef SIGQUIT + sigquit = scm_from_int (SIGQUIT); oldquit = scm_sigaction (sigquit, sig_ign, SCM_UNDEFINED); - +#endif + +#ifdef HAVE_FORK pid = fork (); if (pid == 0) { @@ -164,12 +176,20 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, return scm_from_int (status); } +#else /* !HAVE_FORK */ + status = spawnvp (P_WAIT, execargv[0], (const char * const *)execargv); + scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint)); +#ifdef SIGQUIT + scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit)); +#endif + + return scm_from_int (status); +#endif /* !HAVE_FORK */ } else SCM_WRONG_TYPE_ARG (1, args); } #undef FUNC_NAME -#endif /* HAVE_WAITPID */ #endif /* HAVE_SYSTEM */ From bc945fadd2e94c5ddf1a5b42e7eef5726b5b1068 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 2 Jul 2014 21:21:52 +0300 Subject: [PATCH 23/58] More fixes for deleting files whose ports are not closed. * test-suite/tests/r6rs-files.test: Close the port after using it. * test-suite/tests/posix.test ("mkstemp!"): Close the port after using it. --- test-suite/tests/posix.test | 1 + test-suite/tests/r6rs-files.test | 4 +++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test index 00e9c682e..00632d809 100644 --- a/test-suite/tests/posix.test +++ b/test-suite/tests/posix.test @@ -73,6 +73,7 @@ (str (string-copy template)) (port (mkstemp! str)) (result (not (string=? str template)))) + (close-port port) (delete-file str) result))) diff --git a/test-suite/tests/r6rs-files.test b/test-suite/tests/r6rs-files.test index df5dd22e2..b1b93d140 100644 --- a/test-suite/tests/r6rs-files.test +++ b/test-suite/tests/r6rs-files.test @@ -24,7 +24,9 @@ (with-test-prefix "delete-file" (pass-if "delete-file deletes file" - (let ((filename (port-filename (mkstemp! "T-XXXXXX")))) + (let* ((port (mkstemp! "T-XXXXXX")) + (filename (port-filename port))) + (close-port port) (delete-file filename) (not (file-exists? filename)))) From 317f6a237089a421d8cb57f398eedf6afc600832 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 3 Jul 2014 19:20:00 +0300 Subject: [PATCH 24/58] Unconditionally build and test the ice-9/popen module. * module/Makefile.am (ICE_9_SOURCES): Add ice-9/popen.scm. (ICE_9_SOURCES) [BUILD_ICE_9_POPEN]: Remove conditional addition of ice-9/popen.scm. (SCRIPTS_SOURCES): Add scripts/autofrisk.scm and scripts/scan-api.scm unconditionally. (SCRIPTS_SOURCES) [BUILD_ICE_9_POPEN]: Remove conditional addition of scripts/autofrisk.scm and scripts/scan-api.scm. * configure.ac: Remove the BUILD_ICE_9_POPEN condition. * test-suite/tests/popen.test (if-supported): Don't test for 'fork feature being supported. --- configure.ac | 3 --- module/Makefile.am | 17 ++++------------- test-suite/tests/popen.test | 3 +-- 3 files changed, 5 insertions(+), 18 deletions(-) diff --git a/configure.ac b/configure.ac index 9f87809b5..552a91b64 100644 --- a/configure.ac +++ b/configure.ac @@ -770,9 +770,6 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \ strcoll strcoll_l newlocale utimensat sched_getaffinity \ sched_setaffinity sendfile]) -AM_CONDITIONAL([BUILD_ICE_9_POPEN], - [test "x$enable_posix" = "xyes" && test "x$ac_cv_func_fork" = "xyes"]) - # Reasons for testing: # netdb.h - not in mingw # sys/param.h - not in mingw diff --git a/module/Makefile.am b/module/Makefile.am index 521318b50..b25711653 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -178,7 +178,9 @@ SCRIPTS_SOURCES = \ scripts/summarize-guile-TODO.scm \ scripts/api-diff.scm \ scripts/read-rfc822.scm \ - scripts/snarf-guile-m4-docs.scm + scripts/snarf-guile-m4-docs.scm \ + scripts/autofrisk.scm \ + scripts/scan-api.scm SYSTEM_BASE_SOURCES = \ system/base/pmatch.scm \ @@ -223,6 +225,7 @@ ICE_9_SOURCES = \ ice-9/optargs.scm \ ice-9/poe.scm \ ice-9/poll.scm \ + ice-9/popen.scm \ ice-9/posix.scm \ ice-9/q.scm \ ice-9/rdelim.scm \ @@ -254,18 +257,6 @@ ICE_9_SOURCES = \ ice-9/serialize.scm \ ice-9/local-eval.scm -if BUILD_ICE_9_POPEN - -# This functionality is missing on systems without `fork'---i.e., Windows. -ICE_9_SOURCES += ice-9/popen.scm - -# These modules rely on (ice-9 popen). -SCRIPTS_SOURCES += \ - scripts/autofrisk.scm \ - scripts/scan-api.scm - -endif BUILD_ICE_9_POPEN - srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm SRFI_SOURCES = \ diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test index 27e15dcad..2c0877484 100644 --- a/test-suite/tests/popen.test +++ b/test-suite/tests/popen.test @@ -36,8 +36,7 @@ restore-signals)) (define-syntax-rule (if-supported body ...) - (if (provided? 'fork) - (begin body ...))) + (begin body ...)) (if-supported (use-modules (ice-9 popen)) From 5102fc3790a781af8fc124cc6f1e6a1fd990ceb9 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 3 Jul 2014 19:26:21 +0300 Subject: [PATCH 25/58] Provide a more reasonable default value for stack limit on MS-Windows. * libguile/debug.c (init_stack_limit) [__MINGW32__]: Use VirtualQuery to compute the stack limit on MS-Windows. --- libguile/debug.c | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/libguile/debug.c b/libguile/debug.c index 107b5d438..b7b389628 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -27,6 +27,11 @@ #include #endif +#ifdef __MINGW32__ +# define WIN32_LEAN_AND_MEAN +# include +#endif + #include "libguile/_scm.h" #include "libguile/async.h" #include "libguile/eval.h" @@ -228,7 +233,7 @@ scm_local_eval (SCM exp, SCM env) static void init_stack_limit (void) { -#ifdef HAVE_GETRLIMIT +#if defined HAVE_GETRLIMIT struct rlimit lim; if (getrlimit (RLIMIT_STACK, &lim) == 0) { @@ -242,6 +247,16 @@ init_stack_limit (void) SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits); } errno = 0; +#elif defined __MINGW32__ + MEMORY_BASIC_INFORMATION m; + uintptr_t bytes; + + if (VirtualQuery ((LPCVOID) &m, &m, sizeof m)) + { + bytes = (DWORD_PTR) m.BaseAddress + m.RegionSize + - (DWORD_PTR) m.AllocationBase; + SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits); + } #endif } From 9dc3fc4dd474ce4da6a45dcf197e1f99a9a7047a Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 3 Jul 2014 19:30:02 +0300 Subject: [PATCH 26/58] Fix calculation of CPU set size for getaffinity. * libguile/posix.c (cpu_set_to_bitvector): Use CPU_SETSIZE, not sizeof, to compute the size of the CPU set. --- libguile/posix.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 1dcb5acbb..7fc690305 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1979,9 +1979,9 @@ cpu_set_to_bitvector (const cpu_set_t *cs) SCM bv; size_t cpu; - bv = scm_c_make_bitvector (sizeof (*cs), SCM_BOOL_F); + bv = scm_c_make_bitvector (CPU_SETSIZE, SCM_BOOL_F); - for (cpu = 0; cpu < sizeof (*cs); cpu++) + for (cpu = 0; cpu < CPU_SETSIZE; cpu++) { if (CPU_ISSET (cpu, cs)) /* XXX: This is inefficient but avoids code duplication. */ From 9235f805fa0bacc02a6ddaeceb9867cb37d01d85 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 3 Jul 2014 20:58:19 +0300 Subject: [PATCH 27/58] Fix problems with Windows file names that use backslashes. * libguile/load.c (scm_i_mirror_backslashes): New function. (scm_init_load_path): Call it to produce MS-Windows file names with forward slashes. (FILE_NAME_SEPARATOR_STRING): Define as "/" on all platforms. * libguile/load.h (scm_i_mirror_backslashes): Add prototype. * libguile/init.c (scm_boot_guile): Call scm_i_mirror_backslashes on argv[0]. * libguile/filesys.c (scm_getcwd): Call scm_i_mirror_backslashes on the directory name returned by getcwd. * test-suite/tests/ports.test ("file name separators"): New test. --- libguile/filesys.c | 4 +++ libguile/init.c | 3 ++ libguile/load.c | 57 ++++++++++++++++++++++++++++++------- libguile/load.h | 1 + module/ice-9/boot-9.scm | 2 +- test-suite/tests/ports.test | 11 +++++++ 6 files changed, 67 insertions(+), 11 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 09f6cf9a5..301040a7d 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -51,6 +51,7 @@ #include "libguile/validate.h" #include "libguile/filesys.h" +#include "libguile/load.h" /* for scm_i_mirror_backslashes */ #ifdef HAVE_IO_H @@ -1235,6 +1236,9 @@ SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0, errno = save_errno; SCM_SYSERROR; } + /* On Windows, convert backslashes in current directory to forward + slashes. */ + scm_i_mirror_backslashes (wd); result = scm_from_locale_stringn (wd, strlen (wd)); free (wd); return result; diff --git a/libguile/init.c b/libguile/init.c index 87a69884e..61b81e954 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -311,6 +311,9 @@ scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure) void *res; struct main_func_closure c; + /* On Windows, convert backslashes in argv[0] to forward + slashes. */ + scm_i_mirror_backslashes (argv[0]); c.main_func = main_func; c.closure = closure; c.argc = argc; diff --git a/libguile/load.c b/libguile/load.c index 50b3180e6..d4bb9ef85 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -277,6 +277,41 @@ SCM_DEFINE (scm_parse_path_with_ellipsis, "parse-path-with-ellipsis", 2, 0, 0, } #undef FUNC_NAME +/* On Posix hosts, just return PATH unaltered. On Windows, + destructively replace all backslashes in PATH with Unix-style + forward slashes, so that Scheme code always gets d:/foo/bar style + file names. This avoids multiple subtle problems with comparing + file names as strings, and with redirections in /bin/sh command + lines. + + Note that, if PATH is result of a call to 'getenv', this + destructively modifies the environment variables, so both + scm_getenv and subprocesses will afterwards see the values with + forward slashes. That is OK as long as applied to Guile-specific + environment variables, since having scm_getenv return the same + value as used by the callers of this function is good for + consistency and file-name comparison. Avoid using this function on + values returned by 'getenv' for general-purpose environment + variables; instead, make a copy of the value and work on that. */ +SCM_INTERNAL char * +scm_i_mirror_backslashes (char *path) +{ +#ifdef __MINGW32__ + if (path) + { + char *p = path; + + while (*p) + { + if (*p == '\\') + *p = '/'; + p++; + } + } +#endif + + return path; +} /* Initialize the global variable %load-path, given the value of the SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the @@ -289,7 +324,7 @@ scm_init_load_path () SCM cpath = SCM_EOL; #ifdef SCM_LIBRARY_DIR - env = getenv ("GUILE_SYSTEM_PATH"); + env = scm_i_mirror_backslashes (getenv ("GUILE_SYSTEM_PATH")); if (env && strcmp (env, "") == 0) /* special-case interpret system-path=="" as meaning no system path instead of '("") */ @@ -302,7 +337,7 @@ scm_init_load_path () scm_from_locale_string (SCM_GLOBAL_SITE_DIR), scm_from_locale_string (SCM_PKGDATA_DIR)); - env = getenv ("GUILE_SYSTEM_COMPILED_PATH"); + env = scm_i_mirror_backslashes (getenv ("GUILE_SYSTEM_COMPILED_PATH")); if (env && strcmp (env, "") == 0) /* like above */ ; @@ -345,14 +380,17 @@ scm_init_load_path () cachedir[0] = 0; if (cachedir[0]) - *scm_loc_compile_fallback_path = scm_from_locale_string (cachedir); + { + scm_i_mirror_backslashes (cachedir); + *scm_loc_compile_fallback_path = scm_from_locale_string (cachedir); + } } - env = getenv ("GUILE_LOAD_PATH"); + env = scm_i_mirror_backslashes (getenv ("GUILE_LOAD_PATH")); if (env) path = scm_parse_path_with_ellipsis (scm_from_locale_string (env), path); - env = getenv ("GUILE_LOAD_COMPILED_PATH"); + env = scm_i_mirror_backslashes (getenv ("GUILE_LOAD_COMPILED_PATH")); if (env) cpath = scm_parse_path_with_ellipsis (scm_from_locale_string (env), cpath); @@ -452,11 +490,10 @@ scm_c_string_has_an_ext (char *str, size_t len, SCM extensions) return 0; } -#ifdef __MINGW32__ -#define FILE_NAME_SEPARATOR_STRING "\\" -#else +/* Defined as "/" for Unix and Windows alike, so that file names + constructed by the functions in this module wind up with Unix-style + forward slashes as directory separators. */ #define FILE_NAME_SEPARATOR_STRING "/" -#endif static int is_file_name_separator (SCM c) @@ -877,7 +914,7 @@ canonical_suffix (SCM fname) /* CANON should be absolute. */ canon = scm_canonicalize_path (fname); - + #ifdef __MINGW32__ { size_t len = scm_c_string_length (canon); diff --git a/libguile/load.h b/libguile/load.h index ab75ea3b3..986948d3f 100644 --- a/libguile/load.h +++ b/libguile/load.h @@ -44,6 +44,7 @@ SCM_INTERNAL void scm_init_load_path (void); SCM_INTERNAL void scm_init_load (void); SCM_INTERNAL void scm_init_load_should_auto_compile (void); SCM_INTERNAL void scm_init_eval_in_scheme (void); +SCM_INTERNAL char *scm_i_mirror_backslashes (char *path); #endif /* SCM_LOAD_H */ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index c6d4be111..b2cf48186 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1657,7 +1657,7 @@ VALUE." (or (char=? c #\/) (char=? c #\\))) - (define file-name-separator-string "\\") + (define file-name-separator-string "/") (define (absolute-file-name? file-name) (define (file-name-separator-at-index? idx) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index e7acd6332..6f8fae02e 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -1888,6 +1888,17 @@ (with-fluids ((%file-port-name-canonicalization 'absolute)) (port-filename (open-input-file (%search-load-path "ice-9/q.scm")))))) +(with-test-prefix "file name separators" + + (pass-if "no backslash separators in Windows file names" + ;; In Guile 2.0.11 and earlier, %load-path on Windows could + ;; include file names with backslashes, and `getcwd' on Windows + ;; would always return a directory name with backslashes. + (or (not (file-name-separator? #\\)) + (with-load-path (cons (getcwd) %load-path) + (not (string-index (%search-load-path (basename (test-file))) + #\\)))))) + (delete-file (test-file)) ;;; Local Variables: From 8c6b62e7d5bbc5bfe0c69110156a80539f97b978 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 3 Jul 2014 21:02:23 +0300 Subject: [PATCH 28/58] Untabify some test files. * test-suite/tests/ports.test: Untabify. * test-suite/tests/posix.test: Untabify. * test-suite/tests/r6rs-files.test: Untabify. --- test-suite/tests/ports.test | 530 +++++++++++++++---------------- test-suite/tests/posix.test | 6 +- test-suite/tests/r6rs-files.test | 12 +- 3 files changed, 274 insertions(+), 274 deletions(-) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 6f8fae02e..484b291ea 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -53,12 +53,12 @@ (let loop ((chars '())) (let ((char (read-char port))) (if (eof-object? char) - (list->string (reverse! chars)) - (loop (cons char chars)))))) + (list->string (reverse! chars)) + (loop (cons char chars)))))) (define (read-file filename) (let* ((port (open-input-file filename)) - (string (read-all port))) + (string (read-all port))) (close-port port) string)) @@ -95,7 +95,7 @@ ;;; Write out an s-expression, and read it back. (let ((string '("From fairest creatures we desire increase," - "That thereby beauty's rose might never die,")) + "That thereby beauty's rose might never die,")) (filename (test-file))) (let ((port (open-output-file filename))) (write string port) @@ -103,10 +103,10 @@ (let ((port (open-input-file filename))) (let ((in-string (read port))) (pass-if "file: write and read back list of strings" - (equal? string in-string))) + (equal? string in-string))) (close-port port)) (delete-file filename)) - + ;;; Write out a string, and read it back a character at a time. (let ((string "This is a test string\nwith no newline at the end") (filename (test-file))) @@ -115,7 +115,7 @@ (close-port port)) (let ((in-string (read-file filename))) (pass-if "file: write and read back characters" - (equal? string in-string))) + (equal? string in-string))) (delete-file filename)) ;;; Buffered input/output port with seeking. @@ -124,17 +124,17 @@ (display "J'Accuse" port) (seek port -1 SEEK_CUR) (pass-if "file: r/w 1" - (char=? (read-char port) #\e)) + (char=? (read-char port) #\e)) (pass-if "file: r/w 2" - (eof-object? (read-char port))) + (eof-object? (read-char port))) (seek port -1 SEEK_CUR) (write-char #\x port) (seek port 7 SEEK_SET) (pass-if "file: r/w 3" - (char=? (read-char port) #\x)) + (char=? (read-char port) #\x)) (seek port -2 SEEK_END) (pass-if "file: r/w 4" - (char=? (read-char port) #\s)) + (char=? (read-char port) #\s)) (close-port port) (delete-file filename)) @@ -144,17 +144,17 @@ (display "J'Accuse" port) (seek port -1 SEEK_CUR) (pass-if "file: ub r/w 1" - (char=? (read-char port) #\e)) + (char=? (read-char port) #\e)) (pass-if "file: ub r/w 2" - (eof-object? (read-char port))) + (eof-object? (read-char port))) (seek port -1 SEEK_CUR) (write-char #\x port) (seek port 7 SEEK_SET) (pass-if "file: ub r/w 3" - (char=? (read-char port) #\x)) + (char=? (read-char port) #\x)) (seek port -2 SEEK_END) (pass-if "file: ub r/w 4" - (char=? (read-char port) #\s)) + (char=? (read-char port) #\s)) (close-port port) (delete-file filename)) @@ -163,24 +163,24 @@ (port (open-output-file filename))) (display "J'Accuse" port) (pass-if "file: out tell" - (= (seek port 0 SEEK_CUR) 8)) + (= (seek port 0 SEEK_CUR) 8)) (seek port -1 SEEK_CUR) (write-char #\x port) (close-port port) (let ((iport (open-input-file filename))) (pass-if "file: in tell 0" - (= (seek iport 0 SEEK_CUR) 0)) + (= (seek iport 0 SEEK_CUR) 0)) (read-char iport) (pass-if "file: in tell 1" - (= (seek iport 0 SEEK_CUR) 1)) + (= (seek iport 0 SEEK_CUR) 1)) (unread-char #\z iport) (pass-if "file: in tell 0 after unread" - (= (seek iport 0 SEEK_CUR) 0)) + (= (seek iport 0 SEEK_CUR) 0)) (pass-if "file: unread char still there" - (char=? (read-char iport) #\z)) + (char=? (read-char iport) #\z)) (seek iport 7 SEEK_SET) (pass-if "file: in last char" - (char=? (read-char iport) #\x)) + (char=? (read-char iport) #\x)) (close-port iport)) (delete-file filename)) @@ -188,20 +188,20 @@ (let* ((filename (test-file)) (port (open-output-file filename))) (display (string #\nul (integer->char 255) (integer->char 128) - #\nul) port) + #\nul) port) (close-port port) (let* ((port (open-input-file filename)) - (line (read-line port))) + (line (read-line port))) (pass-if "file: read back NUL 1" - (char=? (string-ref line 0) #\nul)) + (char=? (string-ref line 0) #\nul)) (pass-if "file: read back 255" - (char=? (string-ref line 1) (integer->char 255))) + (char=? (string-ref line 1) (integer->char 255))) (pass-if "file: read back 128" - (char=? (string-ref line 2) (integer->char 128))) + (char=? (string-ref line 2) (integer->char 128))) (pass-if "file: read back NUL 2" - (char=? (string-ref line 3) #\nul)) + (char=? (string-ref line 3) #\nul)) (pass-if "file: EOF" - (eof-object? (read-char port))) + (eof-object? (read-char port))) (close-port port)) (delete-file filename)) @@ -211,11 +211,11 @@ (test-string "one line more or less")) (write-line test-string port) (let* ((in-port (open-input-file filename)) - (line (read-line in-port))) + (line (read-line in-port))) (close-port in-port) (close-port port) (pass-if "file: line buffering" - (string=? line test-string))) + (string=? line test-string))) (delete-file filename)) ;;; read-line should use the port encoding (not the locale encoding). @@ -573,19 +573,19 @@ ;;; ungetting characters and strings. (with-input-from-string "walk on the moon\nmoon" - (lambda () - (read-char) - (unread-char #\a (current-input-port)) - (pass-if "unread-char" - (char=? (read-char) #\a)) - (read-line) - (let ((replacenoid "chicken enchilada")) - (unread-char #\newline (current-input-port)) - (unread-string replacenoid (current-input-port)) - (pass-if "unread-string" - (string=? (read-line) replacenoid))) - (pass-if "unread residue" - (string=? (read-line) "moon")))) + (lambda () + (read-char) + (unread-char #\a (current-input-port)) + (pass-if "unread-char" + (char=? (read-char) #\a)) + (read-line) + (let ((replacenoid "chicken enchilada")) + (unread-char #\newline (current-input-port)) + (unread-string replacenoid (current-input-port)) + (pass-if "unread-string" + (string=? (read-line) replacenoid))) + (pass-if "unread residue" + (string=? (read-line) "moon")))) ;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on ;;; the reading end. try to read a byte: should get EAGAIN or @@ -594,13 +594,13 @@ (r (car p))) (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK)) (pass-if "non-blocking-I/O" - (catch 'system-error - (lambda () (read-char r) #f) - (lambda (key . args) - (and (eq? key 'system-error) - (let ((errno (car (list-ref args 3)))) - (or (= errno EAGAIN) - (= errno EWOULDBLOCK)))))))) + (catch 'system-error + (lambda () (read-char r) #f) + (lambda (key . args) + (and (eq? key 'system-error) + (let ((errno (car (list-ref args 3)))) + (or (= errno EAGAIN) + (= errno EWOULDBLOCK)))))))) ;;;; Pipe (popen) ports. @@ -610,7 +610,7 @@ (in-string (read-all pipe))) (close-pipe pipe) (pass-if "pipe: read" - (equal? in-string "Howdy there, partner!\n"))) + (equal? in-string "Howdy there, partner!\n"))) ;;; Run a command, send some output to it, and see if it worked. (let* ((filename (test-file)) @@ -620,7 +620,7 @@ (close-pipe pipe) (let ((in-string (read-file filename))) (pass-if "pipe: write" - (equal? in-string "Mommy, why does everybody have a bomb?\n"))) + (equal? in-string "Mommy, why does everybody have a bomb?\n"))) (delete-file filename)) (pass-if-equal "pipe, fdopen, and _IOLBF" @@ -657,70 +657,70 @@ ;; Write text to a string port. (let* ((string "Howdy there, partner!") - (in-string (call-with-output-string - (lambda (port) - (display string port) - (newline port))))) + (in-string (call-with-output-string + (lambda (port) + (display string port) + (newline port))))) (pass-if "display text" - (equal? in-string (string-append string "\n")))) - + (equal? in-string (string-append string "\n")))) + ;; Write an s-expression to a string port. (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926)) - (in-sexpr - (call-with-input-string (call-with-output-string - (lambda (port) - (write sexpr port))) - read))) + (in-sexpr + (call-with-input-string (call-with-output-string + (lambda (port) + (write sexpr port))) + read))) (pass-if "write/read sexpr" - (equal? in-sexpr sexpr))) + (equal? in-sexpr sexpr))) ;; seeking and unreading from an input string. (let ((text "that text didn't look random to me")) (call-with-input-string text - (lambda (p) - (pass-if "input tell 0" - (= (seek p 0 SEEK_CUR) 0)) - (read-char p) - (pass-if "input tell 1" - (= (seek p 0 SEEK_CUR) 1)) - (unread-char #\x p) - (pass-if "input tell back to 0" - (= (seek p 0 SEEK_CUR) 0)) - (pass-if "input ungetted char" - (char=? (read-char p) #\x)) - (seek p 0 SEEK_END) - (pass-if "input seek to end" - (= (seek p 0 SEEK_CUR) - (string-length text))) - (unread-char #\x p) - (pass-if "input seek to beginning" - (= (seek p 0 SEEK_SET) 0)) - (pass-if "input reread first char" - (char=? (read-char p) - (string-ref text 0)))))) + (lambda (p) + (pass-if "input tell 0" + (= (seek p 0 SEEK_CUR) 0)) + (read-char p) + (pass-if "input tell 1" + (= (seek p 0 SEEK_CUR) 1)) + (unread-char #\x p) + (pass-if "input tell back to 0" + (= (seek p 0 SEEK_CUR) 0)) + (pass-if "input ungetted char" + (char=? (read-char p) #\x)) + (seek p 0 SEEK_END) + (pass-if "input seek to end" + (= (seek p 0 SEEK_CUR) + (string-length text))) + (unread-char #\x p) + (pass-if "input seek to beginning" + (= (seek p 0 SEEK_SET) 0)) + (pass-if "input reread first char" + (char=? (read-char p) + (string-ref text 0)))))) ;; seeking an output string. (let* ((text (string-copy "123456789")) - (len (string-length text)) - (result (call-with-output-string - (lambda (p) - (pass-if "output tell 0" - (= (seek p 0 SEEK_CUR) 0)) - (display text p) - (pass-if "output tell end" - (= (seek p 0 SEEK_CUR) len)) - (pass-if "output seek to beginning" - (= (seek p 0 SEEK_SET) 0)) - (write-char #\a p) - (seek p -1 SEEK_END) - (pass-if "output seek to last char" - (= (seek p 0 SEEK_CUR) - (- len 1))) - (write-char #\b p))))) + (len (string-length text)) + (result (call-with-output-string + (lambda (p) + (pass-if "output tell 0" + (= (seek p 0 SEEK_CUR) 0)) + (display text p) + (pass-if "output tell end" + (= (seek p 0 SEEK_CUR) len)) + (pass-if "output seek to beginning" + (= (seek p 0 SEEK_SET) 0)) + (write-char #\a p) + (seek p -1 SEEK_END) + (pass-if "output seek to last char" + (= (seek p 0 SEEK_CUR) + (- len 1))) + (write-char #\b p))))) (string-set! text 0 #\a) (string-set! text (- len 1) #\b) (pass-if "output check" - (string=? text result))) + (string=? text result))) (pass-if "encoding failure leads to exception" ;; Prior to 2.0.6, this would trigger a deadlock in `scm_mkstrport'. @@ -1003,10 +1003,10 @@ (close-port out-port)) (list (open-input-file port-loop-temp) - (open-input-pipe (string-append "cat " port-loop-temp)) - (call-with-input-string text (lambda (x) x)) - ;; We don't test soft ports at the moment. - )) + (open-input-pipe (string-append "cat " port-loop-temp)) + (call-with-input-string text (lambda (x) x)) + ;; We don't test soft ports at the moment. + )) (define port-list-names '("file" "pipe" "string")) @@ -1014,55 +1014,55 @@ (define (test-line-counter text second-line final-column) (with-test-prefix "line counter" (let ((ports (input-port-list text))) - (for-each - (lambda (port port-name) - (with-test-prefix port-name - (pass-if "at beginning of input" - (= (port-line port) 0)) - (pass-if "read first character" - (eqv? (read-char port) #\x)) - (pass-if "after reading one character" - (= (port-line port) 0)) - (pass-if "read first newline" - (eqv? (read-char port) #\newline)) - (pass-if "after reading first newline char" - (= (port-line port) 1)) - (pass-if "second line read correctly" - (equal? (read-line port) second-line)) - (pass-if "read-line increments line number" - (= (port-line port) 2)) - (pass-if "read-line returns EOF" - (let loop ((i 0)) - (cond - ((eof-object? (read-line port)) #t) - ((> i 20) #f) - (else (loop (+ i 1)))))) - (pass-if "line count is 5 at EOF" - (= (port-line port) 5)) - (pass-if "column is correct at EOF" - (= (port-column port) final-column)))) - ports port-list-names) - (for-each close-port ports) - (delete-file port-loop-temp)))) + (for-each + (lambda (port port-name) + (with-test-prefix port-name + (pass-if "at beginning of input" + (= (port-line port) 0)) + (pass-if "read first character" + (eqv? (read-char port) #\x)) + (pass-if "after reading one character" + (= (port-line port) 0)) + (pass-if "read first newline" + (eqv? (read-char port) #\newline)) + (pass-if "after reading first newline char" + (= (port-line port) 1)) + (pass-if "second line read correctly" + (equal? (read-line port) second-line)) + (pass-if "read-line increments line number" + (= (port-line port) 2)) + (pass-if "read-line returns EOF" + (let loop ((i 0)) + (cond + ((eof-object? (read-line port)) #t) + ((> i 20) #f) + (else (loop (+ i 1)))))) + (pass-if "line count is 5 at EOF" + (= (port-line port) 5)) + (pass-if "column is correct at EOF" + (= (port-column port) final-column)))) + ports port-list-names) + (for-each close-port ports) + (delete-file port-loop-temp)))) (with-test-prefix "newline" (test-line-counter (string-append "x\n" - "He who receives an idea from me, receives instruction\n" - "himself without lessening mine; as he who lights his\n" - "taper at mine, receives light without darkening me.\n" - " --- Thomas Jefferson\n") + "He who receives an idea from me, receives instruction\n" + "himself without lessening mine; as he who lights his\n" + "taper at mine, receives light without darkening me.\n" + " --- Thomas Jefferson\n") "He who receives an idea from me, receives instruction" 0)) (with-test-prefix "no newline" (test-line-counter (string-append "x\n" - "He who receives an idea from me, receives instruction\n" - "himself without lessening mine; as he who lights his\n" - "taper at mine, receives light without darkening me.\n" - " --- Thomas Jefferson\n" - "no newline here") + "He who receives an idea from me, receives instruction\n" + "himself without lessening mine; as he who lights his\n" + "taper at mine, receives light without darkening me.\n" + " --- Thomas Jefferson\n" + "no newline here") "He who receives an idea from me, receives instruction" 15))) @@ -1072,28 +1072,28 @@ (with-test-prefix "port-line and port-column for output ports" (let ((port (open-output-string))) (pass-if "at beginning of input" - (and (= (port-line port) 0) - (= (port-column port) 0))) + (and (= (port-line port) 0) + (= (port-column port) 0))) (write-char #\x port) (pass-if "after writing one character" - (and (= (port-line port) 0) - (= (port-column port) 1))) + (and (= (port-line port) 0) + (= (port-column port) 1))) (write-char #\newline port) (pass-if "after writing first newline char" - (and (= (port-line port) 1) - (= (port-column port) 0))) + (and (= (port-line port) 1) + (= (port-column port) 0))) (display text port) (pass-if "line count is 5 at end" - (= (port-line port) 5)) + (= (port-line port) 5)) (pass-if "column is correct at end" - (= (port-column port) final-column))))) + (= (port-column port) final-column))))) (test-output-line-counter (string-append "He who receives an idea from me, receives instruction\n" - "himself without lessening mine; as he who lights his\n" - "taper at mine, receives light without darkening me.\n" - " --- Thomas Jefferson\n" - "no newline here") + "himself without lessening mine; as he who lights his\n" + "taper at mine, receives light without darkening me.\n" + " --- Thomas Jefferson\n" + "no newline here") 15) (with-test-prefix "port-column" @@ -1102,115 +1102,115 @@ (pass-if "x" (let ((port (open-output-string))) - (display "x" port) - (= 1 (port-column port)))) + (display "x" port) + (= 1 (port-column port)))) (pass-if "\\a" (let ((port (open-output-string))) - (display "\a" port) - (= 0 (port-column port)))) + (display "\a" port) + (= 0 (port-column port)))) (pass-if "x\\a" (let ((port (open-output-string))) - (display "x\a" port) - (= 1 (port-column port)))) + (display "x\a" port) + (= 1 (port-column port)))) (pass-if "\\x08 backspace" (let ((port (open-output-string))) - (display "\x08" port) - (= 0 (port-column port)))) + (display "\x08" port) + (= 0 (port-column port)))) (pass-if "x\\x08 backspace" (let ((port (open-output-string))) - (display "x\x08" port) - (= 0 (port-column port)))) + (display "x\x08" port) + (= 0 (port-column port)))) (pass-if "\\n" (let ((port (open-output-string))) - (display "\n" port) - (= 0 (port-column port)))) + (display "\n" port) + (= 0 (port-column port)))) (pass-if "x\\n" (let ((port (open-output-string))) - (display "x\n" port) - (= 0 (port-column port)))) + (display "x\n" port) + (= 0 (port-column port)))) (pass-if "\\r" (let ((port (open-output-string))) - (display "\r" port) - (= 0 (port-column port)))) + (display "\r" port) + (= 0 (port-column port)))) (pass-if "x\\r" (let ((port (open-output-string))) - (display "x\r" port) - (= 0 (port-column port)))) + (display "x\r" port) + (= 0 (port-column port)))) (pass-if "\\t" (let ((port (open-output-string))) - (display "\t" port) - (= 8 (port-column port)))) + (display "\t" port) + (= 8 (port-column port)))) (pass-if "x\\t" (let ((port (open-output-string))) - (display "x\t" port) - (= 8 (port-column port))))) + (display "x\t" port) + (= 8 (port-column port))))) (with-test-prefix "input" (pass-if "x" (let ((port (open-input-string "x"))) - (while (not (eof-object? (read-char port)))) - (= 1 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 1 (port-column port)))) (pass-if "\\a" (let ((port (open-input-string "\a"))) - (while (not (eof-object? (read-char port)))) - (= 0 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 0 (port-column port)))) (pass-if "x\\a" (let ((port (open-input-string "x\a"))) - (while (not (eof-object? (read-char port)))) - (= 1 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 1 (port-column port)))) (pass-if "\\x08 backspace" (let ((port (open-input-string "\x08"))) - (while (not (eof-object? (read-char port)))) - (= 0 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 0 (port-column port)))) (pass-if "x\\x08 backspace" (let ((port (open-input-string "x\x08"))) - (while (not (eof-object? (read-char port)))) - (= 0 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 0 (port-column port)))) (pass-if "\\n" (let ((port (open-input-string "\n"))) - (while (not (eof-object? (read-char port)))) - (= 0 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 0 (port-column port)))) (pass-if "x\\n" (let ((port (open-input-string "x\n"))) - (while (not (eof-object? (read-char port)))) - (= 0 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 0 (port-column port)))) (pass-if "\\r" (let ((port (open-input-string "\r"))) - (while (not (eof-object? (read-char port)))) - (= 0 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 0 (port-column port)))) (pass-if "x\\r" (let ((port (open-input-string "x\r"))) - (while (not (eof-object? (read-char port)))) - (= 0 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 0 (port-column port)))) (pass-if "\\t" (let ((port (open-input-string "\t"))) - (while (not (eof-object? (read-char port)))) - (= 8 (port-column port)))) + (while (not (eof-object? (read-char port)))) + (= 8 (port-column port)))) (pass-if "x\\t" (let ((port (open-input-string "x\t"))) - (while (not (eof-object? (read-char port)))) - (= 8 (port-column port)))))) + (while (not (eof-object? (read-char port)))) + (= 8 (port-column port)))))) (with-test-prefix "port-line" @@ -1219,7 +1219,7 @@ ;; systems (pass-if "set most-positive-fixnum/2" (let ((n (quotient most-positive-fixnum 2)) - (port (open-output-string))) + (port (open-output-string))) (set-port-line! port n) (eqv? n (port-line port))))) @@ -1260,7 +1260,7 @@ (gc) ;; but they're still in the port table, so this sees them (port-for-each (lambda (port) - (set! lst (cons port lst)))) + (set! lst (cons port lst)))) ;; this forces completion of the sweeping (gc) (gc) (gc) ;; and (if the bug is present) the cells accumulated in LST are now @@ -1270,10 +1270,10 @@ (with-test-prefix "fdes->port" (pass-if "fdes->ports finds port" - (let* ((port (open-file (test-file) "w")) - (res (not (not (memq port (fdes->ports (port->fdes port))))))) - (close-port port) - res))) + (let* ((port (open-file (test-file) "w")) + (res (not (not (memq port (fdes->ports (port->fdes port))))))) + (close-port port) + res))) ;;; ;;; seek @@ -1285,36 +1285,36 @@ (pass-if "SEEK_CUR" (call-with-output-file (test-file) - (lambda (port) - (display "abcde" port))) + (lambda (port) + (display "abcde" port))) (let ((port (open-file (test-file) "r"))) - (read-char port) - (seek port 2 SEEK_CUR) - (let ((res (eqv? #\d (read-char port)))) - (close-port port) - res))) + (read-char port) + (seek port 2 SEEK_CUR) + (let ((res (eqv? #\d (read-char port)))) + (close-port port) + res))) (pass-if "SEEK_SET" (call-with-output-file (test-file) - (lambda (port) - (display "abcde" port))) + (lambda (port) + (display "abcde" port))) (let ((port (open-file (test-file) "r"))) - (read-char port) - (seek port 3 SEEK_SET) - (let ((res (eqv? #\d (read-char port)))) - (close-port port) - res))) + (read-char port) + (seek port 3 SEEK_SET) + (let ((res (eqv? #\d (read-char port)))) + (close-port port) + res))) (pass-if "SEEK_END" (call-with-output-file (test-file) - (lambda (port) - (display "abcde" port))) + (lambda (port) + (display "abcde" port))) (let ((port (open-file (test-file) "r"))) - (read-char port) - (seek port -2 SEEK_END) - (let ((res (eqv? #\d (read-char port)))) - (close-port port) - res))))) + (read-char port) + (seek port -2 SEEK_END) + (let ((res (eqv? #\d (read-char port)))) + (close-port port) + res))))) ;;; ;;; truncate-file @@ -1332,63 +1332,63 @@ (pass-if-exception "flonum length" exception:wrong-type-arg (call-with-output-file (test-file) - (lambda (port) - (display "hello" port))) + (lambda (port) + (display "hello" port))) (truncate-file (test-file) 1.0)) (pass-if "shorten" (call-with-output-file (test-file) - (lambda (port) - (display "hello" port))) + (lambda (port) + (display "hello" port))) (truncate-file (test-file) 1) (eqv? 1 (stat:size (stat (test-file))))) (pass-if-exception "shorten to current pos" exception:miscellaneous-error (call-with-output-file (test-file) - (lambda (port) - (display "hello" port))) + (lambda (port) + (display "hello" port))) (truncate-file (test-file)))) (with-test-prefix "file descriptor" (pass-if "shorten" (call-with-output-file (test-file) - (lambda (port) - (display "hello" port))) + (lambda (port) + (display "hello" port))) (let ((fd (open-fdes (test-file) O_RDWR))) - (truncate-file fd 1) - (close-fdes fd)) + (truncate-file fd 1) + (close-fdes fd)) (eqv? 1 (stat:size (stat (test-file))))) (pass-if "shorten to current pos" (call-with-output-file (test-file) - (lambda (port) - (display "hello" port))) + (lambda (port) + (display "hello" port))) (let ((fd (open-fdes (test-file) O_RDWR))) - (seek fd 1 SEEK_SET) - (truncate-file fd) - (close-fdes fd)) + (seek fd 1 SEEK_SET) + (truncate-file fd) + (close-fdes fd)) (eqv? 1 (stat:size (stat (test-file)))))) (with-test-prefix "file port" (pass-if "shorten" (call-with-output-file (test-file) - (lambda (port) - (display "hello" port))) + (lambda (port) + (display "hello" port))) (let ((port (open-file (test-file) "r+"))) - (truncate-file port 1) - (close-port port)) + (truncate-file port 1) + (close-port port)) (eqv? 1 (stat:size (stat (test-file))))) (pass-if "shorten to current pos" (call-with-output-file (test-file) - (lambda (port) - (display "hello" port))) + (lambda (port) + (display "hello" port))) (let ((port (open-file (test-file) "r+"))) - (read-char port) - (truncate-file port) - (close-port port)) + (read-char port) + (truncate-file port) + (close-port port)) (eqv? 1 (stat:size (stat (test-file))))))) @@ -1402,11 +1402,11 @@ (read-delimited! "\n" c port 'concat) (pass-if "read-delimited! reads a first line" - (string=? c "defdef\n!!!!!!!!!!!!!")) + (string=? c "defdef\n!!!!!!!!!!!!!")) (read-delimited! "\n" c port 'concat 3) (pass-if "read-delimited! reads a first line" - (string=? c "defghighi\n!!!!!!!!!!")))))) + (string=? c "defghighi\n!!!!!!!!!!")))))) ;;;; char-ready? @@ -1415,7 +1415,7 @@ "howdy" (lambda (port) (pass-if "char-ready? returns true on string port" - (char-ready? port)))) + (char-ready? port)))) ;;; This segfaults on some versions of Guile. We really should run ;;; the tests in a subprocess... @@ -1427,7 +1427,7 @@ port (lambda () (pass-if "char-ready? returns true on string port as default port" - (char-ready?)))))) + (char-ready?)))))) ;;;; pending-eof behavior @@ -1518,15 +1518,15 @@ (with-test-prefix "closing current-input-port" (for-each (lambda (procedure name) - (with-input-from-port - (call-with-input-string "foo" (lambda (p) p)) - (lambda () - (close-port (current-input-port)) - (pass-if-exception name - exception:wrong-type-arg - (procedure))))) - (list read read-char read-line) - '("read" "read-char" "read-line"))) + (with-input-from-port + (call-with-input-string "foo" (lambda (p) p)) + (lambda () + (close-port (current-input-port)) + (pass-if-exception name + exception:wrong-type-arg + (procedure))))) + (list read read-char read-line) + '("read" "read-char" "read-line"))) diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test index 00632d809..9a0e489b4 100644 --- a/test-suite/tests/posix.test +++ b/test-suite/tests/posix.test @@ -70,9 +70,9 @@ (pass-if "filename string modified" (let* ((template "T-XXXXXX") - (str (string-copy template)) - (port (mkstemp! str)) - (result (not (string=? str template)))) + (str (string-copy template)) + (port (mkstemp! str)) + (result (not (string=? str template)))) (close-port port) (delete-file str) result))) diff --git a/test-suite/tests/r6rs-files.test b/test-suite/tests/r6rs-files.test index b1b93d140..9b31a8296 100644 --- a/test-suite/tests/r6rs-files.test +++ b/test-suite/tests/r6rs-files.test @@ -25,7 +25,7 @@ (with-test-prefix "delete-file" (pass-if "delete-file deletes file" (let* ((port (mkstemp! "T-XXXXXX")) - (filename (port-filename port))) + (filename (port-filename port))) (close-port port) (delete-file filename) (not (file-exists? filename)))) @@ -34,9 +34,9 @@ (let ((success #f)) (call/cc (lambda (continuation) - (with-exception-handler - (lambda (condition) - (set! success (i/o-filename-error? condition)) - (continuation)) - (lambda () (delete-file ""))))) + (with-exception-handler + (lambda (condition) + (set! success (i/o-filename-error? condition)) + (continuation)) + (lambda () (delete-file ""))))) success))) From c53b5d891fb8369abcb7fb3f8d00e134ab7b2d9b Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 3 Jul 2014 21:05:49 +0300 Subject: [PATCH 29/58] Remove trailing whitespace from ports.test. --- test-suite/tests/ports.test | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 484b291ea..3791876ae 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -106,7 +106,7 @@ (equal? string in-string))) (close-port port)) (delete-file filename)) - + ;;; Write out a string, and read it back a character at a time. (let ((string "This is a test string\nwith no newline at the end") (filename (test-file))) @@ -663,10 +663,10 @@ (newline port))))) (pass-if "display text" (equal? in-string (string-append string "\n")))) - + ;; Write an s-expression to a string port. (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926)) - (in-sexpr + (in-sexpr (call-with-input-string (call-with-output-string (lambda (port) (write sexpr port))) @@ -996,7 +996,7 @@ ;; Return a list of input ports that all return the same text. ;; We map tests over this list. (define (input-port-list text) - + ;; Create a text file some of the ports will use. (let ((out-port (open-output-file port-loop-temp))) (display text out-port) @@ -1396,10 +1396,10 @@ (with-test-prefix "read-delimited!" (let ((c (make-string 20 #\!))) - (call-with-input-string + (call-with-input-string "defdef\nghighi\n" (lambda (port) - + (read-delimited! "\n" c port 'concat) (pass-if "read-delimited! reads a first line" (string=? c "defdef\n!!!!!!!!!!!!!")) From df8c52e93dfa3965e4714275f4b8cea2c8e0170b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 4 Jul 2014 15:35:06 +0200 Subject: [PATCH 30/58] Recognize arm-* target triplets. Reported by Sylvain Beucler . * module/system/base/target.scm (cpu-endianness): Add case where CPU is "arm". * test-suite/tests/asm-to-bytecode.test ("cross-compilation")["arm-unknown-linux-androideabi"]: New test. --- module/system/base/target.scm | 4 +++- test-suite/tests/asm-to-bytecode.test | 5 ++++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index c74ae679d..cefa951a3 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -1,6 +1,6 @@ ;;; Compilation targets -;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc. +;; Copyright (C) 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 @@ -72,6 +72,8 @@ (endianness big)) ((string-match "^arm.*el" cpu) (endianness little)) + ((string=? "arm" cpu) ;ARMs are LE by default + (endianness little)) (else (error "unknown CPU endianness" cpu))))) diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index 6d2f20e02..62ea0ed9e 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -1,6 +1,6 @@ ;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 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 @@ -205,6 +205,9 @@ (test-target "x86_64-unknown-linux-gnux32" ; x32 ABI (Debian tuplet) (endianness little) 4) + (test-target "arm-unknown-linux-androideabi" + (endianness little) 4) + (pass-if-exception "unknown target" exception:miscellaneous-error (call-with-values (lambda () From 8c75d3ae01ed98ccb623bdff1c25cc17c046145c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 4 Jul 2014 15:37:38 +0200 Subject: [PATCH 31/58] build: Use 'LT_LIB_M' to determine whether -lm is needed. * configure.ac: Use 'LT_LIB_M' instead of 'AC_CHECK_LIB(m, cos)'. Suggested by Sylvain Beucler . --- configure.ac | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/configure.ac b/configure.ac index 552a91b64..f65d72e21 100644 --- a/configure.ac +++ b/configure.ac @@ -692,10 +692,9 @@ AC_TYPE_GETGROUPS AC_TYPE_SIGNAL AC_TYPE_MODE_T -# On mingw -lm is empty, so this test is unnecessary, but it's -# harmless so we don't hard-code to suppress it. -# -AC_CHECK_LIB(m, cos) +dnl Check whether we need -lm. +LT_LIB_M +LIBS="$LIBS $LIBM" AC_CHECK_FUNCS(gethostbyname) if test $ac_cv_func_gethostbyname = no; then From f184e887a6cb09a97cf34feab30eeba4a28a3ae4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 4 Jul 2014 15:52:15 +0200 Subject: [PATCH 32/58] build: Support pthread builds without 'pthread_cancel' support (Android). Reported by Sylvain Beucler . * configure.ac: Check for 'pthread_cancel'. * libguile/threads.c (scm_cancel_thread): Conditionalize on !SCM_USE_PTHREAD_THREADS || defined HAVE_PTHREAD_CANCEL. * test-suite/tests/threads.test (require-cancel-thread): New procedure. ("timed joining fails if timeout exceeded", "join-thread returns timeoutval on timeout", "cancel succeeds", "handler result passed to join", "can cancel self"): Use it. --- configure.ac | 5 ++++- libguile/threads.c | 7 +++++++ test-suite/tests/threads.test | 13 ++++++++++++- 3 files changed, 23 insertions(+), 2 deletions(-) diff --git a/configure.ac b/configure.ac index f65d72e21..a323f7093 100644 --- a/configure.ac +++ b/configure.ac @@ -1371,8 +1371,11 @@ case "$with_threads" in # pthread_attr_get_np - "np" meaning "non portable" says it # all; specific to FreeBSD # pthread_sigmask - not available on mingw + # pthread_cancel - not available on Android (Bionic libc) # - AC_CHECK_FUNCS(pthread_attr_getstack pthread_getattr_np pthread_get_stackaddr_np pthread_attr_get_np pthread_sigmask) + AC_CHECK_FUNCS([pthread_attr_getstack pthread_getattr_np \ + pthread_get_stackaddr_np pthread_attr_get_np pthread_sigmask \ + pthread_cancel]) # On past versions of Solaris, believe 8 through 10 at least, you # had to write "pthread_once_t foo = { PTHREAD_ONCE_INIT };". diff --git a/libguile/threads.c b/libguile/threads.c index 15e491990..6ae6818c5 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1156,6 +1156,11 @@ SCM_DEFINE (scm_yield, "yield", 0, 0, 0, } #undef FUNC_NAME +/* Some systems, notably Android, lack 'pthread_cancel'. Don't provide + 'cancel-thread' on these systems. */ + +#if !SCM_USE_PTHREAD_THREADS || defined HAVE_PTHREAD_CANCEL + SCM_DEFINE (scm_cancel_thread, "cancel-thread", 1, 0, 0, (SCM thread), "Asynchronously force the target @var{thread} to terminate. @var{thread} " @@ -1181,6 +1186,8 @@ SCM_DEFINE (scm_cancel_thread, "cancel-thread", 1, 0, 0, } #undef FUNC_NAME +#endif + SCM_DEFINE (scm_set_thread_cleanup_x, "set-thread-cleanup!", 2, 0, 0, (SCM thread, SCM proc), "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. " diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index 817812051..3b7a3e440 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -1,6 +1,7 @@ ;;;; threads.test --- Tests for Guile threading. -*- scheme -*- ;;;; -;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;;;; Copyright 2003, 2006, 2007, 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 @@ -36,6 +37,11 @@ (equal? '(a b c) '(a b c)) a)) +(define (require-cancel-thread) + ;; Skip the test when 'cancel-thread' is unavailable. + (unless (defined? 'cancel-thread) + (throw 'unresolved))) + (if (provided? 'threads) (begin @@ -277,6 +283,7 @@ (with-test-prefix "join-thread" (pass-if "timed joining fails if timeout exceeded" + (require-cancel-thread) (let* ((m (make-mutex)) (c (make-condition-variable)) (t (begin-thread (begin (lock-mutex m) @@ -286,6 +293,7 @@ (not r))) (pass-if "join-thread returns timeoutval on timeout" + (require-cancel-thread) (let* ((m (make-mutex)) (c (make-condition-variable)) (t (begin-thread (begin (lock-mutex m) @@ -335,6 +343,7 @@ (with-test-prefix "cancel-thread" (pass-if "cancel succeeds" + (require-cancel-thread) (let ((m (make-mutex))) (lock-mutex m) (let ((t (begin-thread (begin (lock-mutex m) 'foo)))) @@ -343,6 +352,7 @@ #t))) (pass-if "handler result passed to join" + (require-cancel-thread) (let ((m (make-mutex))) (lock-mutex m) (let ((t (begin-thread (lock-mutex m)))) @@ -351,6 +361,7 @@ (eq? (join-thread t) 'foo)))) (pass-if "can cancel self" + (require-cancel-thread) (let ((m (make-mutex))) (lock-mutex m) (let ((t (begin-thread (begin From d40752513fff3306bed31e40721e627720b2f8ff Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 28 Jun 2014 15:24:29 +0200 Subject: [PATCH 33/58] Fix bit-count* bug * libguile/bitvectors.c (scm_bit_count_star): Fix typo introduced in 2005 refactor (!) in which the second arg was erroneously taken from the first arg. * test-suite/tests/bitvectors.test: Add test. * doc/ref/api-compound.texi: Fix doc example for u32vector selector. --- doc/ref/api-compound.texi | 2 +- libguile/bitvectors.c | 2 +- test-suite/tests/bitvectors.test | 4 ++++ 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 055de9935..8ec32d687 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -1142,7 +1142,7 @@ For example, @example (bit-count* #*01110111 #*11001101 #t) @result{} 3 -(bit-count* #*01110111 #u(7 0 4) #f) @result{} 2 +(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2 @end example @end deffn diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index 01584906c..af2e94716 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -713,7 +713,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, ssize_t kv_inc; const scm_t_uint32 *kv_bits; - kv_bits = scm_bitvector_elements (v, &kv_handle, + kv_bits = scm_bitvector_elements (kv, &kv_handle, &kv_off, &kv_len, &kv_inc); if (v_len != kv_len) diff --git a/test-suite/tests/bitvectors.test b/test-suite/tests/bitvectors.test index 8541576aa..d9dfa136d 100644 --- a/test-suite/tests/bitvectors.test +++ b/test-suite/tests/bitvectors.test @@ -70,3 +70,7 @@ (let ((v (bitvector #t #t #f #f))) (bit-set*! v #*101 #f) (equal? v #*0100)))) + +(with-test-prefix "bit-count*" + (pass-if-equal 3 (bit-count* #*01110111 #*11001101 #t)) + (pass-if-equal 2 (bit-count* #*01110111 #u32(7 0 4) #f))) From ffd3e55cfd12a3559621e3130d613d319243512d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 4 Jul 2014 17:26:41 +0200 Subject: [PATCH 34/58] Recognize more ARM targets. Suggested by Dale P. Smith. * module/system/base/target.scm (cpu-endianness): Add cases for "arm.*eb", "^aarch64.*be", and "aarch64". Change "arm" case to "arm.*". (triplet-pointer-size): Allow underscore as in 'aarch64_be'. * test-suite/tests/asm-to-bytecode.test ("cross-compilation")["armeb-unknown-linux-gnu", "aarch64-linux-gnu", "aarch64_be-linux-gnu"]: New tests. --- module/system/base/target.scm | 10 ++++++++-- test-suite/tests/asm-to-bytecode.test | 6 ++++++ 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index cefa951a3..31e3fea79 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -72,7 +72,13 @@ (endianness big)) ((string-match "^arm.*el" cpu) (endianness little)) - ((string=? "arm" cpu) ;ARMs are LE by default + ((string-match "^arm.*eb" cpu) + (endianness big)) + ((string-prefix? "arm" cpu) ;ARMs are LE by default + (endianness little)) + ((string-match "^aarch64.*be" cpu) + (endianness big)) + ((string=? "aarch64" cpu) (endianness little)) (else (error "unknown CPU endianness" cpu))))) @@ -97,7 +103,7 @@ ((string-match "^x86_64-.*-gnux32" triplet) 4) ; x32 ((string-match "64$" cpu) 8) - ((string-match "64[lbe][lbe]$" cpu) 8) + ((string-match "64_?[lbe][lbe]$" cpu) 8) ((member cpu '("sparc" "powerpc" "mips" "mipsel")) 4) ((string-match "^arm.*" cpu) 4) (else (error "unknown CPU word size" cpu))))) diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index 62ea0ed9e..8aeba84f7 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -207,6 +207,12 @@ (test-target "arm-unknown-linux-androideabi" (endianness little) 4) + (test-target "armeb-unknown-linux-gnu" + (endianness big) 4) + (test-target "aarch64-linux-gnu" + (endianness little) 8) + (test-target "aarch64_be-linux-gnu" + (endianness big) 8) (pass-if-exception "unknown target" exception:miscellaneous-error From 8857e271d810623868509f837d17613195f6528c Mon Sep 17 00:00:00 2001 From: Ian Price Date: Wed, 30 Jul 2014 18:58:16 +0100 Subject: [PATCH 35/58] Prevent add-to-load-path from adding duplicate entries * module/ice-9/boot-9.scm (add-to-load-path): Remove argument from %load-path (if it exists) before pushing. This also means that the `elt' will always be at the front of %load-path. --- module/ice-9/boot-9.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index b2cf48186..872594b20 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1748,7 +1748,7 @@ VALUE." (define-syntax-rule (add-to-load-path elt) "Add ELT to Guile's load path, at compile-time and at run-time." (eval-when (expand load eval) - (set! %load-path (cons elt %load-path)))) + (set! %load-path (cons elt (delete elt %load-path))))) (define %load-verbosely #f) (define (assert-load-verbosity v) (set! %load-verbosely v)) From b072b8e6924bb1a05ffb66bcbde30b375df5443f Mon Sep 17 00:00:00 2001 From: Ian Price Date: Thu, 31 Jul 2014 16:05:58 +0100 Subject: [PATCH 36/58] Provide curried version of define*-public. * module/ice-9/curried-definitions.scm (define*-public): New macro. --- module/ice-9/curried-definitions.scm | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/module/ice-9/curried-definitions.scm b/module/ice-9/curried-definitions.scm index fa369906c..7545338e3 100644 --- a/module/ice-9/curried-definitions.scm +++ b/module/ice-9/curried-definitions.scm @@ -17,7 +17,8 @@ (define-module (ice-9 curried-definitions) #:replace ((cdefine . define) (cdefine* . define*) - define-public)) + define-public + define*-public)) (define-syntax cdefine (syntax-rules () @@ -44,3 +45,13 @@ (begin (define name val) (export name))))) + +(define-syntax define*-public + (syntax-rules () + ((_ (head . rest) body body* ...) + (define*-public head + (lambda* rest body body* ...))) + ((_ name val) + (begin + (define* name val) + (export name))))) From da6ecd4923a8c5422e695604b2e06733a7ae074e Mon Sep 17 00:00:00 2001 From: David Kastrup Date: Sun, 10 Aug 2014 22:50:08 -0400 Subject: [PATCH 37/58] Clarify that object-properties cannot be reliably applied to numbers. * doc/ref/api-utility.texi (Object Properties)[make-object-property]: Clarify that object-properties cannot be reliably applied to numbers. Signed-off-by: David Kastrup --- doc/ref/api-utility.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-utility.texi b/doc/ref/api-utility.texi index ffdf27687..e2b60e2f9 100644 --- a/doc/ref/api-utility.texi +++ b/doc/ref/api-utility.texi @@ -222,7 +222,7 @@ setting of @var{obj}'s @var{property}. A single object property created by @code{make-object-property} can associate distinct property values with all Scheme values that are -distinguishable by @code{eq?} (including, for example, integers). +distinguishable by @code{eq?} (ruling out numeric values). Internally, object properties are implemented using a weak key hash table. This means that, as long as a Scheme value with property values From 1e9249e0cd0814937cb4bdda84c3002e24adbcb2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 12 Aug 2014 22:23:07 +0200 Subject: [PATCH 38/58] doc: "!#" does not need to appear on a line of its own. * doc/ref/api-evaluation.texi (Block Comments): Remove "which must appear on a line of their own". Reported by David Michael . --- doc/ref/api-evaluation.texi | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index c441dffee..88f713d40 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -215,8 +215,9 @@ convention is used when indenting code in Emacs' Scheme mode. In addition to the standard line comments defined by R5RS, Guile has another comment type for multiline comments, called @dfn{block comments}. This type of comment begins with the character sequence -@code{#!} and ends with the characters @code{!#}, which must appear on a -line of their own. These comments are compatible with the block +@code{#!} and ends with the characters @code{!#}. + +These comments are compatible with the block comments in the Scheme Shell @file{scsh} (@pxref{The Scheme shell (scsh)}). The characters @code{#!} were chosen because they are the magic characters used in shell scripts for indicating that the name of From 7c848fe5724666edf667e753b5c828c21748fe31 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 13 Aug 2014 18:41:15 +0300 Subject: [PATCH 39/58] Make temporary file in coding.test work on MS-Windows. * test-suite/tests/coding.test (with-temp-file): Instead of hard-coding "/tmp" as the temporary directory, use $TMPDIR or $TEMP from the environment, and fall back on "/tmp" if none of those 2 is defined. --- test-suite/tests/coding.test | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/coding.test b/test-suite/tests/coding.test index b57ef7da7..5f643f871 100644 --- a/test-suite/tests/coding.test +++ b/test-suite/tests/coding.test @@ -20,7 +20,10 @@ #:use-module (test-suite lib)) (define (with-temp-file proc) - (let* ((name (string-copy "/tmp/coding-test.XXXXXX")) + (let* ((tmpdir (or (getenv "TMPDIR") + (getenv "TEMP") + "/tmp")) + (name (string-append tmpdir "/coding-test.XXXXXX")) (port (mkstemp! name))) (let ((res (with-throw-handler #t From cfefef6bd96294b373104e85d80bc3f4f3fb482b Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 13 Aug 2014 22:47:32 -0400 Subject: [PATCH 40/58] Copy the result from 'nl_langinfo' before it can be overwritten. Based on a patch by Eli Zaretskii . * libguile/i18n.c (copy_string_or_null): New static function. (scm_nl_langinfo): Use 'copy_string_or_null' to copy the result from 'nl_langinfo' and 'nl_langinfo_l' before the next call and before releasing the locale mutex. --- libguile/i18n.c | 28 ++++++++++++++++++---------- 1 file changed, 18 insertions(+), 10 deletions(-) diff --git a/libguile/i18n.c b/libguile/i18n.c index e38e5602e..c6b9b845e 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 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 @@ -1465,6 +1465,14 @@ SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact", Note: We don't use Gnulib's `nl_langinfo' module because it's currently not as complete as the compatibility hacks in `i18n.scm'. */ +static char * +copy_string_or_null (const char *s) +{ + if (s == NULL) + return NULL; + else + return strdup (s); +} SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, (SCM item, SCM locale), @@ -1496,8 +1504,8 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, if (c_locale != NULL) { #ifdef USE_GNU_LOCALE_API - c_result = nl_langinfo_l (c_item, c_locale); - codeset = nl_langinfo_l (CODESET, c_locale); + c_result = copy_string_or_null (nl_langinfo_l (c_item, c_locale)); + codeset = copy_string_or_null (nl_langinfo_l (CODESET, c_locale)); #else /* !USE_GNU_LOCALE_API */ /* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale mutex is already taken. */ @@ -1521,8 +1529,8 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, scm_locale_error (FUNC_NAME, lsec_err); else { - c_result = nl_langinfo (c_item); - codeset = nl_langinfo (CODESET); + c_result = copy_string_or_null (nl_langinfo (c_item)); + codeset = copy_string_or_null (nl_langinfo (CODESET)); restore_locale_settings (&lsec_prev_locale); free_locale_settings (&lsec_prev_locale); @@ -1531,13 +1539,10 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, } else { - c_result = nl_langinfo (c_item); - codeset = nl_langinfo (CODESET); + c_result = copy_string_or_null (nl_langinfo (c_item)); + codeset = copy_string_or_null (nl_langinfo (CODESET)); } - if (c_result != NULL) - c_result = strdup (c_result); - unlock_locale_mutex (); if (c_result == NULL) @@ -1669,6 +1674,9 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, } } + if (codeset != NULL) + free (codeset); + return result; } #undef FUNC_NAME From c6a7930b38a55aa2402f4ed722a4ef460ad67810 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 15 Aug 2014 09:47:52 +0300 Subject: [PATCH 41/58] On MS-Windows, don't return file names with backslashes from search-path. * libguile/load.c (search_path): On MS-Windows, convert all backslashes to forward slashes if the file was found on PATH. --- libguile/load.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/load.c b/libguile/load.c index d4bb9ef85..74ccd088f 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -657,7 +657,8 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, if (stat (buf.buf, stat_buf) == 0 && ! (stat_buf->st_mode & S_IFDIR)) { - result = scm_from_locale_string (buf.buf); + result = + scm_from_locale_string (scm_i_mirror_backslashes (buf.buf)); goto end; } } From 8ac39b38d14f47b6028030fa829f1fe7d0499f21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 26 Aug 2014 23:40:22 +0200 Subject: [PATCH 42/58] Handle ~p in 'format' warnings. Fixes . Reported by Frank Terbeck . * module/language/tree-il/analyze.scm (format-string-argument-count): Add case for ~p. * test-suite/tests/tree-il.test ("warnings")["format"]("~p", "~p, too few arguments", "~:p", "~:@p, too many arguments", "~:@p, too few arguments"): New tests. --- module/language/tree-il/analyze.scm | 13 ++++++++- test-suite/tests/tree-il.test | 44 +++++++++++++++++++++++++++++ 2 files changed, 56 insertions(+), 1 deletion(-) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index badce9f77..ef625d4f1 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -1,6 +1,7 @@ ;;; TREE-IL -> GLIL compiler -;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2001, 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 @@ -1273,6 +1274,16 @@ accurate information is missing from a given `tree-il' element." conditions end-group (+ 1 min-count) (+ 1 max-count))) + ((#\p #\P) (let* ((colon? (memq #\: params)) + (min-count (if colon? + (max 1 min-count) + (+ 1 min-count)))) + (loop (cdr chars) 'literal '() + conditions end-group + min-count + (if colon? + (max max-count min-count) + (+ 1 max-count))))) ((#\[) (loop chars 'literal '() '() (let ((selector (previous-number params)) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 34bc810c4..f8920334a 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -1698,6 +1698,50 @@ (number? (string-contains (car w) "expected 3, got 2"))))) + (pass-if "~p" + (null? (call-with-warnings + (lambda () + (compile '(((@ (ice-9 format) format) #f "thing~p" 2)) + #:opts %opts-w-format + #:to 'assembly))))) + + (pass-if "~p, too few arguments" + (let ((w (call-with-warnings + (lambda () + (compile '((@ (ice-9 format) format) #f "~p") + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 1, got 0"))))) + + (pass-if "~:p" + (null? (call-with-warnings + (lambda () + (compile '(((@ (ice-9 format) format) #f "~d thing~:p" 2)) + #:opts %opts-w-format + #:to 'assembly))))) + + (pass-if "~:@p, too many arguments" + (let ((w (call-with-warnings + (lambda () + (compile '((@ (ice-9 format) format) #f "~d pupp~:@p" 5 5) + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 1, got 2"))))) + + (pass-if "~:@p, too few arguments" + (let ((w (call-with-warnings + (lambda () + (compile '((@ (ice-9 format) format) #f "pupp~:@p") + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 1, got 0"))))) + (pass-if "~?" (null? (call-with-warnings (lambda () From 9233c05585c908b6e1612001eda51cf9c0324d91 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 26 Aug 2014 23:41:14 +0200 Subject: [PATCH 43/58] Thank Franck. --- THANKS | 1 + 1 file changed, 1 insertion(+) diff --git a/THANKS b/THANKS index e6268730b..4038d5eeb 100644 --- a/THANKS +++ b/THANKS @@ -167,6 +167,7 @@ For fixes or providing information which led to a fix: Cesar Strauss Klaus Stehle Rainer Tammer + Frank Terbeck Samuel Thibault Richard Todd Sree Harsha Totakura From b38c19a5a5935dc5b874625767ed4951452f46c2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 17 Sep 2014 13:43:55 +0200 Subject: [PATCH 44/58] tests: Link test against Gnulib. Reported by Eli Zaretskii . * test-suite/standalone/Makefile.am (test_scm_take_locale_symbol_LDADD): Add libgnu.la, for the 'strdup' replacement. --- test-suite/standalone/Makefile.am | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index 6f676ebc8..2042c23cd 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -193,7 +193,8 @@ TESTS += test-scm-c-read # test-scm-take-locale-symbol test_scm_take_locale_symbol_SOURCES = test-scm-take-locale-symbol.c test_scm_take_locale_symbol_CFLAGS = ${test_cflags} -test_scm_take_locale_symbol_LDADD = $(LIBGUILE_LDADD) +test_scm_take_locale_symbol_LDADD = \ + $(LIBGUILE_LDADD) $(top_builddir)/lib/libgnu.la check_PROGRAMS += test-scm-take-locale-symbol TESTS += test-scm-take-locale-symbol From a85c78ea1393985fdb6e6678dea19135c553d341 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 19 Sep 2014 21:18:09 -0400 Subject: [PATCH 45/58] VM: ASM_MUL for ARM: Add earlyclobber constraint to the SMULL outputs. Reported by Rob Browning . * libguile/vm-i-scheme.c (ASM_MUL)[ARM]: Add earlyclobber (&) constraint to the SMULL output registers. --- libguile/vm-i-scheme.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 587aa9566..162efab0b 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -1,5 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, - * 2014 Free Software Foundation, Inc. +/* Copyright (C) 2001, 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 @@ -363,7 +362,7 @@ VM_DEFINE_FUNCTION (149, ge, "ge?", 2) { \ scm_t_signed_bits rlo, rhi; \ asm ("smull %0, %1, %2, %3\n" \ - : "=r" (rlo), "=r" (rhi) \ + : "=&r" (rlo), "=&r" (rhi) \ : "r" (SCM_UNPACK (x) - scm_tc2_int), \ "r" (SCM_I_INUM (y))); \ if (SCM_LIKELY (SCM_SRS (rlo, 31) == rhi)) \ From 156119b0223cf14d335ebda84701a69b2ba95757 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 20 Sep 2014 03:49:46 -0400 Subject: [PATCH 46/58] Do not assume that 64-bit integers will be 64-bit aligned. * libguile/foreign.c (raw_bytecode, objcode_cells): * libguile/gsubr.c (raw_bytecode, objcode_cells): Use SCM_ALIGNED to ensure 64-bit alignment. --- libguile/foreign.c | 6 +++--- libguile/gsubr.c | 7 ++++--- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/libguile/foreign.c b/libguile/foreign.c index 01af90019..5c30d5458 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 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 @@ -814,7 +814,7 @@ SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0, static const struct { - scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */ + SCM_ALIGNED (8) scm_t_uint64 dummy; /* alignment */ const scm_t_uint8 bytes[10 * (sizeof (struct scm_objcode) + 8 + sizeof (struct scm_objcode) + 32)]; } raw_bytecode = { @@ -867,7 +867,7 @@ make_objcode_trampoline (unsigned int nargs) static const struct { - scm_t_uint64 dummy; /* alignment */ + SCM_ALIGNED (8) scm_t_uint64 dummy; /* alignment */ scm_t_cell cells[10 * 2]; /* 10 double cells */ } objcode_cells = { 0, diff --git a/libguile/gsubr.c b/libguile/gsubr.c index b6f261faf..f6357e16a 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995-2001, 2006, 2008-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 @@ -213,7 +214,7 @@ */ static const struct { - scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */ + SCM_ALIGNED (8) scm_t_uint64 dummy; /* alignment */ const scm_t_uint8 bytes[121 * (sizeof (struct scm_objcode) + 16 + sizeof (struct scm_objcode) + 32)]; } raw_bytecode = { @@ -317,7 +318,7 @@ static const struct static const struct { - scm_t_uint64 dummy; /* alignment */ + SCM_ALIGNED (8) scm_t_uint64 dummy; /* alignment */ scm_t_cell cells[121 * 2]; /* 11*11 double cells */ } objcode_cells = { 0, From bed025bd2569b1c033f24d7d9e660e39ebf65cac Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 20 Sep 2014 03:59:51 -0400 Subject: [PATCH 47/58] VM: Allow the C compiler to choose FP_REG on ARM. Reported by Rob Browning . * libguile/vm-engine.h (IP_REG)[__arm__]: Remove explicit register choice ("r7") for FP_REG, which was reported to cause compilation failures on ARM. --- libguile/vm-engine.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index 46d4cfff0..e618be79f 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +/* Copyright (C) 2001, 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 @@ -81,7 +81,7 @@ #ifdef __arm__ #define IP_REG asm("r9") #define SP_REG asm("r8") -#define FP_REG asm("r7") +#define FP_REG #endif #endif From 97c520fd3ff5ae0305b6d236e0bc31f794a6cce6 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 20 Sep 2014 04:05:43 -0400 Subject: [PATCH 48/58] VM: Use register "a3" for IP_REG on m68k. Subset of a patch by Andreas Schwab . Reported by Rob Browning . * libguile/vm-engine.h (IP_REG)[__mc68000__]: Use register "a3". --- libguile/vm-engine.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index e618be79f..178828cea 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -74,7 +74,7 @@ #define FP_REG asm("%r16") #endif #ifdef __mc68000__ -#define IP_REG asm("a5") +#define IP_REG asm("a3") #define SP_REG asm("a4") #define FP_REG #endif From 8f230e3341c344afe891cc45d0370c42a7813ace Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 20 Sep 2014 04:09:14 -0400 Subject: [PATCH 49/58] SRFI-43: vector-concatenate: Fix error message. * module/srfi/srfi-43.scm (vector-concatenate): Fix the 'who' of an error message. --- module/srfi/srfi-43.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm index 88a3f3fec..c1612aa37 100644 --- a/module/srfi/srfi-43.scm +++ b/module/srfi/srfi-43.scm @@ -304,7 +304,7 @@ from the subsequent locations in VEC ..." Append each vector in LIST-OF-VECTORS. Equivalent to: (apply vector-append LIST-OF-VECTORS)" - (assert-vectors vs 'vector-append) + (assert-vectors vs 'vector-concatenate) (%vector-concatenate vs)) (define (vector-empty? vec) From 0fce815b1b50bc80092acfea44d03e4739140478 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 20 Sep 2014 04:42:49 -0400 Subject: [PATCH 50/58] Document #:prefix option in use-module clauses. * doc/ref/api-modules.texi (Using Guile Modules): Document #:prefix option. --- doc/ref/api-modules.texi | 35 ++++++++++++++++++++++++----------- 1 file changed, 24 insertions(+), 11 deletions(-) diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi index 0f54e01ab..e9d7aecf3 100644 --- a/doc/ref/api-modules.texi +++ b/doc/ref/api-modules.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, 2008, 2009, 2010, 2011, 2012, 2013 +@c Copyright (C) 1996, 1997, 2000-2004, 2007-2014 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -126,6 +126,16 @@ them to suit the current module's needs. For example: #:renamer (symbol-prefix-proc 'unixy:))) @end lisp +@noindent +or more simply: + +@cindex prefix +@lisp +(use-modules ((ice-9 popen) + #:select ((open-pipe . pipe-open) close-pipe) + #:prefix unixy:)) +@end lisp + Here, the interface specification is more complex than before, and the result is that a custom interface with only two bindings is created and subsequently accessed by the current module. The mapping of old to new @@ -184,21 +194,24 @@ whose public interface is found and used. @cindex binding renamer @lisp - (MODULE-NAME [#:select SELECTION] [#:renamer RENAMER]) + (MODULE-NAME [#:select SELECTION] + [#:prefix PREFIX] + [#:renamer RENAMER]) @end lisp in which case a custom interface is newly created and used. @var{module-name} is a list of symbols, as above; @var{selection} is a -list of selection-specs; and @var{renamer} is a procedure that takes a -symbol and returns its new name. A selection-spec is either a symbol or -a pair of symbols @code{(ORIG . SEEN)}, where @var{orig} is the name in -the used module and @var{seen} is the name in the using module. Note -that @var{seen} is also passed through @var{renamer}. +list of selection-specs; @var{prefix} is a symbol that is prepended to +imported names; and @var{renamer} is a procedure that takes a symbol and +returns its new name. A selection-spec is either a symbol or a pair of +symbols @code{(ORIG . SEEN)}, where @var{orig} is the name in the used +module and @var{seen} is the name in the using module. Note that +@var{seen} is also modified by @var{prefix} and @var{renamer}. -The @code{#:select} and @code{#:renamer} clauses are optional. If both are -omitted, the returned interface has no bindings. If the @code{#:select} -clause is omitted, @var{renamer} operates on the used module's public -interface. +The @code{#:select}, @code{#:prefix}, and @code{#:renamer} clauses are +optional. If all are omitted, the returned interface has no bindings. +If the @code{#:select} clause is omitted, @var{prefix} and @var{renamer} +operate on the used module's public interface. In addition to the above, @var{spec} can also include a @code{#:version} clause, of the form: From f2742bdd68619323da2c5f9f65f10684f6522e3c Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 20 Sep 2014 04:51:02 -0400 Subject: [PATCH 51/58] guild disassemble: Use #:prefix instead of #:renamer. * module/scripts/disassemble.scm: Use #:prefix instead of #:renamer in #:use-module clause. --- module/scripts/disassemble.scm | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/module/scripts/disassemble.scm b/module/scripts/disassemble.scm index 7dab2dde9..6e99bf3e7 100644 --- a/module/scripts/disassemble.scm +++ b/module/scripts/disassemble.scm @@ -1,6 +1,6 @@ ;;; Disassemble --- Disassemble .go files into something human-readable -;; Copyright 2005, 2008, 2009, 2011 Free Software Foundation, Inc. +;; Copyright 2005, 2008, 2009, 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 @@ -28,8 +28,7 @@ (define-module (scripts disassemble) #:use-module (system vm objcode) - #:use-module ((language assembly disassemble) - #:renamer (symbol-prefix-proc 'asm:)) + #:use-module ((language assembly disassemble) #:prefix asm:) #:export (disassemble)) (define %summary "Disassemble a compiled .go file.") From 8442211ef0029581b35f784489afcf210491fc41 Mon Sep 17 00:00:00 2001 From: David Kastrup Date: Sat, 20 Sep 2014 05:17:54 -0400 Subject: [PATCH 52/58] Fix SCM_SMOB_OBJECT{_,_0_,_1_,_2_,_3_}LOC. Fixes . * libguile/smob.h (SCM_SMOB_OBJECT_LOC, SCM_SMOB_OBJECT_0_LOC) (SCM_SMOB_OBJECT_1_LOC, SCM_SMOB_OBJECT_2_LOC) (SCM_SMOB_OBJECT_3_LOC): These elementary API macros have been broken by commit 56164dc47f6616b359f0ad23be208f01a77b55fa in 2009. Signed-off-by: David Kastrup --- libguile/smob.h | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/libguile/smob.h b/libguile/smob.h index 60abe3733..f910a242e 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -156,14 +156,14 @@ scm_new_double_smob (scm_t_bits tc, scm_t_bits data1, #define SCM_SET_SMOB_OBJECT_1(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 1, (obj))) #define SCM_SET_SMOB_OBJECT_2(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 2, (obj))) #define SCM_SET_SMOB_OBJECT_3(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 3, (obj))) -#define SCM_SMOB_OBJECT_0_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 0))) -#define SCM_SMOB_OBJECT_1_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 1))) -#define SCM_SMOB_OBJECT_2_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 2))) -#define SCM_SMOB_OBJECT_3_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 3))) +#define SCM_SMOB_OBJECT_0_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 0)) +#define SCM_SMOB_OBJECT_1_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 1)) +#define SCM_SMOB_OBJECT_2_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 2)) +#define SCM_SMOB_OBJECT_3_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 3)) #define SCM_SMOB_OBJECT(x) (SCM_SMOB_OBJECT_1 (x)) #define SCM_SET_SMOB_OBJECT(x,obj) (SCM_SET_SMOB_OBJECT_1 ((x), (obj))) -#define SCM_SMOB_OBJECT_LOC(x) (SCM_SMOB_OBJECT_1_LOC (x))) +#define SCM_SMOB_OBJECT_LOC(x) (SCM_SMOB_OBJECT_1_LOC (x)) #define SCM_SMOB_APPLY_0(x) (scm_call_0 (x)) From 76a8db27c65b59879a8c27363f374035b233d6b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 20 Sep 2014 14:36:09 +0200 Subject: [PATCH 53/58] build: Use 'libtoolize' in autogen.sh. Fixes . Reported by Rob Browning . * autogen.sh: Invoke 'libtoolize' instead of 'libtool'. --- autogen.sh | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/autogen.sh b/autogen.sh index 5187cd4aa..af1ade60d 100755 --- a/autogen.sh +++ b/autogen.sh @@ -15,11 +15,7 @@ autoconf --version echo "" automake --version echo "" -if test "`uname -s`" = Darwin; then - glibtool --version -else - libtool --version -fi +libtoolize --version echo "" ${M4:-m4} --version echo "" From 3a3316e200ac49f0e8e9004c233747efd9f54a04 Mon Sep 17 00:00:00 2001 From: David Michael Date: Sun, 21 Sep 2014 23:21:25 -0400 Subject: [PATCH 54/58] guile-readline: Use the current directory if HOME is unset. * guile-readline/ice-9/readline.scm (history-file): When the HOME environment variable is unset, use the current directory instead. --- guile-readline/ice-9/readline.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm index cfaaef362..2142fbf14 100644 --- a/guile-readline/ice-9/readline.scm +++ b/guile-readline/ice-9/readline.scm @@ -118,7 +118,8 @@ (define-once the-readline-port #f) (define-once history-variable "GUILE_HISTORY") -(define-once history-file (string-append (getenv "HOME") "/.guile_history")) +(define-once history-file + (string-append (or (getenv "HOME") ".") "/.guile_history")) (define-public readline-port (let ((do (lambda (r/w) From 447af515a3ca2525974efa12fea8513223540403 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 22 Sep 2014 22:51:23 +0200 Subject: [PATCH 55/58] Add 'EXIT_SUCCESS' and 'EXIT_FAILURE'. Suggested by Frank Terbeck . * libguile/posix.c (scm_init_posix): Define 'EXIT_SUCCESS' and 'EXIT_FAILURE'. * doc/ref/posix.texi (Processes): Document them. --- doc/ref/posix.texi | 10 ++++++++-- libguile/posix.c | 6 ++++++ 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 7ca2fb01b..acf17276a 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1793,13 +1793,19 @@ Example: (system* "echo" "foo" "bar") Terminate the current process with proper unwinding of the Scheme stack. The exit status zero if @var{status} is not supplied. If @var{status} is supplied, and it is an integer, that integer is used as the exit -status. If @var{status} is @code{#t} or @code{#f}, the exit status is 0 -or 1, respectively. +status. If @var{status} is @code{#t} or @code{#f}, the exit status is +@var{EXIT_SUCCESS} or @var{EXIT_FAILURE}, respectively. The procedure @code{exit} is an alias of @code{quit}. They have the same functionality. @end deffn +@defvr {Scheme Variable} EXIT_SUCCESS +@defvrx {Scheme Variable} EXIT_FAILURE +These constants represent the standard exit codes for success (zero) or +failure (one.) +@end defvr + @deffn {Scheme Procedure} primitive-exit [status] @deffnx {Scheme Procedure} primitive-_exit [status] @deffnx {C Function} scm_primitive_exit (status) diff --git a/libguile/posix.c b/libguile/posix.c index 7fc690305..2654716d3 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -2247,6 +2247,12 @@ void scm_init_posix () { scm_add_feature ("posix"); +#ifdef EXIT_SUCCESS + scm_c_define ("EXIT_SUCCESS", scm_from_int (EXIT_SUCCESS)); +#endif +#ifdef EXIT_FAILURE + scm_c_define ("EXIT_FAILURE", scm_from_int (EXIT_FAILURE)); +#endif #ifdef HAVE_GETEUID scm_add_feature ("EIDs"); #endif From ff4af3df238815e434b62693a3c02b8213667ebe Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 24 Sep 2014 22:03:58 -0400 Subject: [PATCH 56/58] doc: Improve description of vector-unfold and vector-unfold-right. * doc/ref/srfi-modules.texi (SRFI-43 Constructors)[vector-unfold]: Improve description. * module/srfi/srfi-43.scm (vector-unfold, vector-unfold-right): Improve docstrings. --- doc/ref/srfi-modules.texi | 14 +++++++------- module/srfi/srfi-43.scm | 16 ++++++++-------- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index b1776c6a0..2cf9fd154 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.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, 2006, 2007, 2008, -@c 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014 +@c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node SRFI Support @@ -4524,11 +4524,11 @@ Create and return a vector whose elements are @var{x} @enddots{}. @end deffn @deffn {Scheme Procedure} vector-unfold f length initial-seed @dots{} -The fundamental vector constructor. Create a vector whose length is -@var{length} and iterates across each index k from 0 up to -@var{length} - 1, applying @var{f} at each iteration to the current index -and current seeds, in that order, to receive n + 1 values: first, the -element to put in the kth slot of the new vector and n new seeds for +The fundamental vector constructor. Create a vector whose length +is @var{length} and iterates across each index k from 0 up to +@var{length} - 1, applying @var{f} at each iteration to the current +index and current seeds, in that order, to receive n + 1 values: the +element to put in the kth slot of the new vector, and n new seeds for the next iteration. It is an error for the number of seeds to vary between iterations. diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm index c1612aa37..153b0cbcd 100644 --- a/module/srfi/srfi-43.scm +++ b/module/srfi/srfi-43.scm @@ -104,10 +104,10 @@ The fundamental vector constructor. Create a vector whose length is LENGTH and iterates across each index k from 0 up to LENGTH - 1, -applying F at each iteration to the current index and current seeds, -in that order, to receive n + 1 values: first, the element to put in -the kth slot of the new vector and n new seeds for the next iteration. -It is an error for the number of seeds to vary between iterations." +applying F at each iteration to the current index and current seeds, in +that order, to receive n + 1 values: the element to put in the kth slot +of the new vector, and n new seeds for the next iteration. It is an +error for the number of seeds to vary between iterations." ((f len) (assert-procedure f 'vector-unfold) (assert-nonneg-exact-integer len 'vector-unfold) @@ -154,10 +154,10 @@ It is an error for the number of seeds to vary between iterations." The fundamental vector constructor. Create a vector whose length is LENGTH and iterates across each index k from LENGTH - 1 down to 0, -applying F at each iteration to the current index and current seeds, -in that order, to receive n + 1 values: first, the element to put in -the kth slot of the new vector and n new seeds for the next iteration. -It is an error for the number of seeds to vary between iterations." +applying F at each iteration to the current index and current seeds, in +that order, to receive n + 1 values: the element to put in the kth slot +of the new vector, and n new seeds for the next iteration. It is an +error for the number of seeds to vary between iterations." ((f len) (assert-procedure f 'vector-unfold-right) (assert-nonneg-exact-integer len 'vector-unfold-right) From 7a71a45cfd6092402d540e9bc5d2432941a8a336 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 28 Sep 2014 12:51:11 -0400 Subject: [PATCH 57/58] peval: Handle optional argument inits that refer to previous arguments. Fixes . Reported by Josep Portella Florit . * module/language/tree-il/peval.scm (inlined-application): When inlining an application whose operator is a lambda expression with optional arguments that rely on default initializers, expand into a series of nested let expressions, to ensure that previous arguments are in scope when the default initializers are evaluated. * test-suite/tests/peval.test ("partial evaluation"): Add tests. --- module/language/tree-il/peval.scm | 94 ++++++++++++++++++++++++------- test-suite/tests/peval.test | 86 +++++++++++++++++++++++++++- 2 files changed, 160 insertions(+), 20 deletions(-) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index bd92edc69..7dfbf6fb6 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1,6 +1,6 @@ ;;; Tree-IL partial evaluator -;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc. +;; Copyright (C) 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 @@ -1313,24 +1313,80 @@ top-level bindings from ENV and return the resulting expression." (nopt (if opt (length opt) 0)) (key (source-expression proc))) (define (inlined-application) - (make-let src - (append req - (or opt '()) - (if rest (list rest) '())) - gensyms - (if (> nargs (+ nreq nopt)) - (append (list-head orig-args (+ nreq nopt)) - (list - (make-application - #f - (make-primitive-ref #f 'list) - (drop orig-args (+ nreq nopt))))) - (append orig-args - (drop inits (- nargs nreq)) - (if rest - (list (make-const #f '())) - '()))) - body)) + (cond + ((= nargs (+ nreq nopt)) + (make-let src + (append req + (or opt '()) + (if rest (list rest) '())) + gensyms + (append orig-args + (if rest + (list (make-const #f '())) + '())) + body)) + ((> nargs (+ nreq nopt)) + (make-let src + (append req + (or opt '()) + (list rest)) + gensyms + (append (take orig-args (+ nreq nopt)) + (list (make-application + #f + (make-primitive-ref #f 'list) + (drop orig-args (+ nreq nopt))))) + body)) + (else + ;; Here we handle the case where nargs < nreq + nopt, + ;; so the rest argument (if any) will be empty, and + ;; there will be optional arguments that rely on their + ;; default initializers. + ;; + ;; The default initializers of optional arguments + ;; may refer to earlier arguments, so in the general + ;; case we must expand into a series of nested let + ;; expressions. + ;; + ;; In the generated code, the outermost let + ;; expression will bind all arguments provided by + ;; the application's argument list, as well as the + ;; empty rest argument, if any. Each remaining + ;; optional argument that relies on its default + ;; initializer will be bound within an inner let. + ;; + ;; rest-gensyms, rest-vars and rest-inits will have + ;; either 0 or 1 elements. They are oddly named, but + ;; allow simpler code below. + (let*-values + (((non-rest-gensyms rest-gensyms) + (split-at gensyms (+ nreq nopt))) + ((provided-gensyms default-gensyms) + (split-at non-rest-gensyms nargs)) + ((provided-vars default-vars) + (split-at (append req opt) nargs)) + ((rest-vars) + (if rest (list rest) '())) + ((rest-inits) + (if rest + (list (make-const #f '())) + '())) + ((default-inits) + (drop inits (- nargs nreq)))) + (make-let src + (append provided-vars rest-vars) + (append provided-gensyms rest-gensyms) + (append orig-args rest-inits) + (fold-right (lambda (var gensym init body) + (make-let src + (list var) + (list gensym) + (list init) + body)) + body + default-vars + default-gensyms + default-inits)))))) (cond ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt)))) diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index 5b003d26d..21834290e 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -1,7 +1,7 @@ ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; Andy Wingo --- May 2009 ;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 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 @@ -410,6 +410,90 @@ '(2 3)) (const 7)) + (pass-if-peval + ;; Higher order with optional argument (default uses earlier argument). + ;; + ((lambda* (f x #:optional (y (+ 3 (car x)))) + (+ y (f (* (car x) (cadr x))))) + (lambda (x) + (+ x 1)) + '(2 3)) + (const 12)) + + (pass-if-peval + ;; Higher order with optional arguments + ;; (default uses earlier optional argument). + ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))) + (+ y z (f (* (car x) (cadr x))))) + (lambda (x) + (+ x 1)) + '(2 3)) + (const 20)) + + (pass-if-peval + ;; Higher order with optional arguments (one caller-supplied value, + ;; one default that uses earlier optional argument). + ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))) + (+ y z (f (* (car x) (cadr x))))) + (lambda (x) + (+ x 1)) + '(2 3) + -3) + (const 4)) + + (pass-if-peval + ;; Higher order with optional arguments (caller-supplied values). + ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))) + (+ y z (f (* (car x) (cadr x))))) + (lambda (x) + (+ x 1)) + '(2 3) + -3 + 17) + (const 21)) + + (pass-if-peval + ;; Higher order with optional and rest arguments (one + ;; caller-supplied value, one default that uses earlier optional + ;; argument). + ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)) + #:rest r) + (list r (+ y z (f (* (car x) (cadr x)))))) + (lambda (x) + (+ x 1)) + '(2 3) + -3) + (apply (primitive list) (const ()) (const 4))) + + (pass-if-peval + ;; Higher order with optional and rest arguments + ;; (caller-supplied values for optionals). + ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)) + #:rest r) + (list r (+ y z (f (* (car x) (cadr x)))))) + (lambda (x) + (+ x 1)) + '(2 3) + -3 + 17) + (apply (primitive list) (const ()) (const 21))) + + (pass-if-peval + ;; Higher order with optional and rest arguments + ;; (caller-supplied values for optionals and rest). + ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)) + #:rest r) + (list r (+ y z (f (* (car x) (cadr x)))))) + (lambda (x) + (+ x 1)) + '(2 3) + -3 + 17 + 8 + 3) + (let (r) (_) ((apply (primitive list) (const 8) (const 3))) + (apply (primitive list) (lexical r _) (const 21)))) + (pass-if-peval ;; Higher order with optional argument (caller-supplied value). ((lambda* (f x #:optional (y 0)) From 3157d455039f137ca5dfa8b9fbc4a3404ce00606 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 12 Sep 2014 17:00:59 +0200 Subject: [PATCH 58/58] Add (ice-9 unicode) module * libguile/unicode.c: * libguile/unicode.h: * test-suite/tests/unicode.test: * module/ice-9/unicode.scm: New files. * module/Makefile.am: * libguile/Makefile.am: * test-suite/Makefile.am: * libguile/init.c: Wire new files into the build. * doc/ref/api-data.texi: Add docs. --- doc/ref/api-data.texi | 18 +++++++ libguile/Makefile.am | 4 ++ libguile/init.c | 2 + libguile/unicode.c | 95 +++++++++++++++++++++++++++++++++++ libguile/unicode.h | 37 ++++++++++++++ module/Makefile.am | 3 +- module/ice-9/unicode.scm | 26 ++++++++++ test-suite/Makefile.am | 1 + test-suite/tests/unicode.test | 28 +++++++++++ 9 files changed, 213 insertions(+), 1 deletion(-) create mode 100644 libguile/unicode.c create mode 100644 libguile/unicode.h create mode 100644 module/ice-9/unicode.scm create mode 100644 test-suite/tests/unicode.test diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index acdf9ca2b..c1dd7610f 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -2331,6 +2331,24 @@ lowercase, and titlecase forms respectively. The type @code{scm_t_wchar} is a signed, 32-bit integer. @end deftypefn +Characters also have ``formal names'', which are defined by Unicode. +These names can be accessed in Guile from the @code{(ice-9 unicode)} +module: + +@example +(use-modules (ice-9 unicode)) +@end example + +@deffn {Scheme Procedure} char->formal-name chr +Return the formal all-upper-case Unicode name of @var{ch}, +as a string, or @code{#f} if the character has no name. +@end deffn + +@deffn {Scheme Procedure} formal-name->char name +Return the character whose formal all-upper-case Unicode name is +@var{name}, or @code{#f} if no such character is known. +@end deffn + @node Character Sets @subsection Character Sets diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 2bdf71f65..55dbc5fec 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -215,6 +215,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ threads.c \ throw.c \ trees.c \ + unicode.c \ uniform.c \ values.c \ variable.c \ @@ -312,6 +313,7 @@ DOT_X_FILES = \ threads.x \ throw.x \ trees.x \ + unicode.x \ uniform.x \ values.x \ variable.x \ @@ -413,6 +415,7 @@ DOT_DOC_FILES = \ threads.doc \ throw.doc \ trees.doc \ + unicode.doc \ uniform.doc \ values.doc \ variable.doc \ @@ -651,6 +654,7 @@ modinclude_HEADERS = \ throw.h \ trees.h \ validate.h \ + unicode.h \ uniform.h \ values.h \ variable.h \ diff --git a/libguile/init.c b/libguile/init.c index 61b81e954..f55841337 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -129,6 +129,7 @@ #include "libguile/throw.h" #include "libguile/arrays.h" #include "libguile/trees.h" +#include "libguile/unicode.h" #include "libguile/values.h" #include "libguile/variable.h" #include "libguile/vectors.h" @@ -512,6 +513,7 @@ scm_i_init_guile (void *base) #endif scm_bootstrap_i18n (); scm_init_script (); + scm_init_unicode (); scm_init_goops (); diff --git a/libguile/unicode.c b/libguile/unicode.c new file mode 100644 index 000000000..65d319a1d --- /dev/null +++ b/libguile/unicode.c @@ -0,0 +1,95 @@ +/* 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, see + * . + */ + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include +#include +#include +#include +#include + +#include "libguile/_scm.h" +#include "libguile/validate.h" + +#include "libguile/unicode.h" + + + +SCM_DEFINE (scm_char_to_formal_name, "char->formal-name", 1, 0, 0, + (SCM ch), + "Return the formal all-upper-case unicode name of @var{ch},\n" + "as a string. If the character has no name, return @code{#f}.") +#define FUNC_NAME s_scm_char_to_formal_name +{ + char buf[UNINAME_MAX + 1]; + + SCM_VALIDATE_CHAR (1, ch); + + memset(buf, 0, UNINAME_MAX + 1); + + if (unicode_character_name (SCM_CHAR (ch), buf)) + return scm_from_latin1_string (buf); + + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_formal_name_to_char, "formal-name->char", 1, 0, 0, + (SCM name), + "Return the character whose formal all-upper-case unicode name is\n" + "@var{name}, or @code{#f} if no such character is known.") +#define FUNC_NAME s_scm_formal_name_to_char +{ + char *c_name; + scm_t_wchar ret; + + SCM_VALIDATE_STRING (1, name); + + c_name = scm_to_latin1_string (name); + ret = unicode_name_character (c_name); + free (c_name); + + return ret == UNINAME_INVALID ? SCM_BOOL_F : SCM_MAKE_CHAR (ret); +} +#undef FUNC_NAME + +static void +scm_load_unicode (void) +{ +#ifndef SCM_MAGIC_SNARFER +#include "libguile/unicode.x" +#endif +} + +void +scm_init_unicode (void) +{ + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_unicode", + (scm_t_extension_init_func)scm_load_unicode, + NULL); +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/unicode.h b/libguile/unicode.h new file mode 100644 index 000000000..88261c109 --- /dev/null +++ b/libguile/unicode.h @@ -0,0 +1,37 @@ +/* classes: h_files */ + +#ifndef SCM_UNICODE_H +#define SCM_UNICODE_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, see + * . + */ + + + +#include "libguile/__scm.h" + +SCM_INTERNAL SCM scm_formal_name_to_char (SCM); +SCM_INTERNAL SCM scm_char_to_formal_name (SCM); +SCM_INTERNAL void scm_init_unicode (void); + +#endif /* SCM_UNICODE_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/module/Makefile.am b/module/Makefile.am index b25711653..a9aaa76ae 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -255,7 +255,8 @@ ICE_9_SOURCES = \ ice-9/weak-vector.scm \ ice-9/list.scm \ ice-9/serialize.scm \ - ice-9/local-eval.scm + ice-9/local-eval.scm \ + ice-9/unicode.scm srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm diff --git a/module/ice-9/unicode.scm b/module/ice-9/unicode.scm new file mode 100644 index 000000000..534d9c480 --- /dev/null +++ b/module/ice-9/unicode.scm @@ -0,0 +1,26 @@ +;; unicode + +;;;; 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, see +;;;; . +;;;; + +(define-module (ice-9 unicode) + #:export (formal-name->char + char->formal-name)) + +(eval-when (expand load eval) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_unicode")) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index a050f830e..3b1035310 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -176,6 +176,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/time.test \ tests/tree-il.test \ tests/types.test \ + tests/unicode.test \ tests/version.test \ tests/vectors.test \ tests/vlist.test \ diff --git a/test-suite/tests/unicode.test b/test-suite/tests/unicode.test new file mode 100644 index 000000000..5cfafca26 --- /dev/null +++ b/test-suite/tests/unicode.test @@ -0,0 +1,28 @@ +;;;; unicode.test -*- scheme -*- +;;;; +;;;; 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, see +;;;; . +;;;; + +(define-module (test-suite test-unicode) + #:use-module (test-suite lib) + #:use-module (ice-9 unicode)) + +(pass-if-equal "LATIN SMALL LETTER A" (char->formal-name #\a)) +(pass-if-equal #\a (formal-name->char "LATIN SMALL LETTER A")) + +(pass-if-equal #f (char->formal-name #\nul)) +(pass-if-equal #f (formal-name->char "not a known formal name"))