Merge.

.dir-locals.el

@@ -14,6 +14,7 @@
      (eval . (put 'with-test-prefix/c&e 'scheme-indent-function 1))
      (eval . (put 'with-code-coverage  'scheme-indent-function 1))
      (eval . (put 'with-statprof       'scheme-indent-function 1))
+     (eval . (put 'with-target         'scheme-indent-function 1))
      (eval . (put 'let-gensyms         'scheme-indent-function 1))
      (eval . (put 'let-fresh           'scheme-indent-function 2))
      (eval . (put 'with-fresh-name-state 'scheme-indent-function 1))

GUILE-VERSION

@@ -3,7 +3,7 @@
 # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'.
 GUILE_MAJOR_VERSION=3
 GUILE_MINOR_VERSION=0
-GUILE_MICRO_VERSION=2
+GUILE_MICRO_VERSION=4
 
 GUILE_EFFECTIVE_VERSION=3.0
 
@@ -14,9 +14,10 @@ GUILE_EFFECTIVE_VERSION=3.0
 # Makefile.am.
 
 # See libtool info pages for more information on how and when to
-# change these.
+# change these.  Note: We consider the ABI of default builds, and not
+# that of '--disable-deprecated' builds.
 
-LIBGUILE_INTERFACE_CURRENT=2
+LIBGUILE_INTERFACE_CURRENT=3
-LIBGUILE_INTERFACE_REVISION=1
+LIBGUILE_INTERFACE_REVISION=0
-LIBGUILE_INTERFACE_AGE=1
+LIBGUILE_INTERFACE_AGE=2
 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}"

NEWS

@@ -4,6 +4,15 @@ See the end for copying conditions.
 
 Please send Guile bug reports to bug-guile@gnu.org.
 
+
+Changes in 3.0.4 (since 3.0.3)
+
+This release fixes the SONAME of libguile-3.0.so, which was erroneously
+bumped in 3.0.3 compared to 3.0.2.  Distributions are strongly
+encouraged to use 3.0.4 instead of 3.0.3.
+
+Thanks to Chris Vine for reporting the issue.
+
 
 Changes in 3.0.3 (since 3.0.2)
 
@@ -45,6 +54,11 @@ the first Scheme compiler.  Because the baseline compiler runs faster
 and includes less code than the CPS compiler, Guile takes less time to
 build.
 
+** New 'pipeline' procedure in (ice-9 popen)
+
+The 'pipeline' procedure provides a simple way to spawn command pipeline
+as one would do in a shell.
+
 ** Refreshed bitvector facility
 
 See "Bit Vectors" in the manual, for more on all of these.
@@ -80,6 +94,35 @@ This replaces bit-invert!.
 
 These replace the wonky "bit-set*!" procedure.
 
+* Bug fixes
+
+** statprof reports the names of primitives
+
+Previously statprof would show strings like "anon #x1234" for primitives
+written in C.
+
+** Compiler reduces 'equal?' when passed a character literal
+
+The compiler now properly reduces expressions such as (equal? c #\x) to
+(eq? c #\x).  This was not the case in 3.0.2, which could lead to slower
+code, especially in 'match' expressions with many clauses with with
+character literals.
+
+** JIT bugs on ARMv7 have been fixed
+   (<https://bugs.gnu.org/40737>,
+    <https://gitlab.com/wingo/lightening/-/issues/12>)
+
+** 'http-get', 'http-post', etc. now honor #:verify-certificates?
+   (<https://bugs.gnu.org/40486>)
+
+** web: Accept URI host names consisting only of hex digits
+   (<https://bugs.gnu.org/40582>)
+
+** (web http) parser recognizes the CONNECT and PATCH methods
+
+** Initial revealed count of file ports is now zero
+   (<https://bugs.gnu.org/41204>)
+
 * New deprecations
 
 ** Old bitvector interfaces deprecated

doc/ref/api-data.texi

@@ -3183,9 +3183,10 @@ produce the corresponding string element.  The order in which
 @deffnx {C Function} scm_string_join (ls, delimiter, grammar)
 Append the string in the string list @var{ls}, using the string
 @var{delimiter} as a delimiter between the elements of @var{ls}.
-@var{grammar} is a symbol which specifies how the delimiter is
+@var{delimiter} defaults to @w{@samp{ }}, that is, strings in @var{ls}
-placed between the strings, and defaults to the symbol
+are appended with the space character in between them.  @var{grammar} is
-@code{infix}.
+a symbol which specifies how the delimiter is placed between the
+strings, and defaults to the symbol @code{infix}.
 
 @table @code
 @item infix

doc/ref/api-io.texi

@@ -1596,7 +1596,7 @@ of bytes read.
 
 @item write
 A port's @code{write} implementation flushes write buffers to the
-mutable store.  A port's @code{read} implementation fills read buffers.
+mutable store.
 It should write out bytes from the supplied bytevector @code{src},
 starting at offset @code{start} and continuing for @code{count} bytes,
 and return the number of bytes that were written.

doc/ref/posix.texi

@@ -1040,6 +1040,21 @@ If @var{suffix} is provided, and is equal to the end of
 @end lisp
 @end deffn
 
+@deffn {Scheme Procedure} canonicalize-path path
+@deffnx {C Function} scm_canonicalize_path (path)
+Return the canonical (absolute) path of @var{path}.
+A canonical path has no @code{.} or @code{..} components,
+nor any repeated path separators (@code{/}) nor symlinks.
+
+Raises an error if any component of @var{path} does not
+exist.
+
+@lisp
+(canonicalize-path "test.xml")
+@result{} "/tmp/test.xml"
+@end lisp
+@end deffn
+
 @deffn {Scheme Procedure} file-exists? filename
 Return @code{#t} if the file named @var{filename} exists, @code{#f} if
 not.

doc/ref/scheme-using.texi

@@ -311,6 +311,9 @@ will be printed farther to the right, though if the width of the
 indentation passes the @var{max-indent}, the indentation is abbreviated.
 @end deffn
 
+These REPL commands can also be called as regular functions in scheme
+code on including the @code{(ice-9 time)} module.
+
 @node Debug Commands
 @subsubsection Debug Commands
 

doc/ref/srfi-modules.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019
+@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019, 2020
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -824,7 +824,7 @@ predicate or a comparison object for determining which elements are to
 be searched.
 
 @deffn {Scheme Procedure} find pred lst
-Return the first element of @var{lst} which satisfies the predicate
+Return the first element of @var{lst} that satisfies the predicate
 @var{pred} and @code{#f} if no such element is found.
 @end deffn
 

doc/ref/web.texi

@@ -772,11 +772,11 @@ The MD5 digest of a resource.
 @end deftypevr
 
 @deftypevr {HTTP Header} List content-range
-A range specification, as a list of three elements: the symbol
+Range specification as a list of three elements: the symbol
-@code{bytes}, either the symbol @code{*} or a pair of integers,
+@code{bytes}, either the symbol @code{*} or a pair of integers
-indicating the byte rage, and either @code{*} or an integer, for the
+indicating the byte range, and either @code{*} or an integer indicating
-instance length.  Used to indicate that a response only includes part of
+the instance length.  Used to indicate that a response only includes
-a resource.
+part of a resource.
 @example
 (parse-header 'content-range "bytes 10-20/*")
 @result{} (bytes (10 . 20) *)

libguile/lightening/.gitlab-ci.yml

@@ -1,4 +1,4 @@
-image: debian:testing
+image: debian:stable
 
 before_script:
   - dpkg --add-architecture i386
@@ -30,4 +30,9 @@ aarch64:
 armhf:
   stage: test
   script:
-    - make -C tests test-armv7 CC_ARMv7=arm-linux-gnueabihf-gcc
+    - make -C tests test-armv7 CC_ARMv7="arm-linux-gnueabihf-gcc -marm"
+
+armhf-thumb:
+  stage: test
+  script:
+    - make -C tests test-armv7 CC_ARMv7="arm-linux-gnueabihf-gcc -mthumb"

libguile/lightening/lightening.h

@@ -91,6 +91,8 @@ enum jit_reloc_kind
   JIT_RELOC_JCC_WITH_VENEER,
   JIT_RELOC_LOAD_FROM_POOL,
 #endif
+  JIT_RELOC_MASK = 15,
+  JIT_RELOC_FLAG_0 = 16,
 };
 
 typedef struct jit_reloc

libguile/lightening/lightening/aarch64.c

@@ -90,9 +90,9 @@ DEFINE_ENCODER(size, 2, 22, unsigned, uint32_t)
   {                                                                     \
     return read_signed_bitfield(*loc, kind##_width, kind##_shift);      \
   }                                                                     \
-  static int offset_in_##name##_range(ptrdiff_t diff) maybe_unused;     \
+  static int offset_in_##name##_range(ptrdiff_t diff, int flags) maybe_unused; \
   static int                                                            \
-  offset_in_##name##_range(ptrdiff_t diff)                              \
+  offset_in_##name##_range(ptrdiff_t diff, int flags)                   \
   {                                                                     \
     return in_signed_range(diff, kind##_width);                         \
   }                                                                     \
@@ -114,8 +114,12 @@ DEFINE_ENCODER(size, 2, 22, unsigned, uint32_t)
     }                                                                   \
   }
 
-DEFINE_PATCHABLE_INSTRUCTION(jmp, simm26, JMP_WITH_VENEER, 2);
+#define DEFINE_PATCHABLE_INSTRUCTIONS(name, kind, RELOC, rsh)           \
-DEFINE_PATCHABLE_INSTRUCTION(jcc, simm19, JCC_WITH_VENEER, 2);
+    DEFINE_PATCHABLE_INSTRUCTION(name, kind, RELOC, rsh);               \
+    DEFINE_PATCHABLE_INSTRUCTION(veneer_##name, kind, RELOC, rsh);
+
+DEFINE_PATCHABLE_INSTRUCTIONS(jmp, simm26, JMP_WITH_VENEER, 2);
+DEFINE_PATCHABLE_INSTRUCTIONS(jcc, simm19, JCC_WITH_VENEER, 2);
 DEFINE_PATCHABLE_INSTRUCTION(load_from_pool, simm19, LOAD_FROM_POOL, 2);
 
 struct veneer

libguile/lightening/lightening/arm-cpu.c

@@ -1,5 +1,5 @@
 /*
- * Copyright (C) 2012-2017, 2019  Free Software Foundation, Inc.
+ * Copyright (C) 2012-2017,2019-2020  Free Software Foundation, Inc.
  *
  * This file is part of GNU lightning.
  *
@@ -186,6 +186,8 @@
 
 #define _NOREG (jit_gpr_regno(_PC))
 
+#define JIT_RELOC_B JIT_RELOC_FLAG_0
+
 static void
 emit_wide_thumb(jit_state_t *_jit, uint32_t inst)
 {
@@ -193,8 +195,15 @@ emit_wide_thumb(jit_state_t *_jit, uint32_t inst)
   emit_u16_with_pool(_jit, inst & 0xffff);
 }
 
-/* from binutils */
+static uint32_t
-#  define rotate_left(v, n)     (v << n | v >> (32 - n))
+rotate_left(uint32_t v, uint32_t n) {
+  if (n == 0) {
+    return v;
+  }
+  ASSERT(n < 32);
+  return (v << n | v >> (32 - n));
+}
+
 static int
 encode_arm_immediate(unsigned int v)
 {
@@ -221,7 +230,7 @@ encode_thumb_immediate(unsigned int v)
     return ((v & 0xff) | (1 << 12));
   /* abcdefgh 00000000 abcdefgh 00000000 */
   if (((v & 0xffff0000) >> 16) == (v & 0xffff) && (v & 0xff) == 0)
-    return ((v & 0x000000ff) | (2 << 12));
+    return (((v & 0x0000ff00) >> 8) | (2 << 12));
   /* abcdefgh abcdefgh abcdefgh abcdefgh */
   if ( (v &    0xff)        == ((v &     0xff00) >>  8) &&
        ((v &   0xff00) >> 8) == ((v &   0xff0000) >> 16) &&
@@ -265,9 +274,12 @@ write_wide_thumb(uint32_t *loc, uint32_t v)
 }
 
 static int
-offset_in_jmp_range(int32_t offset)
+offset_in_jmp_range(int32_t offset, int flags)
 {
-  return -0x800000 <= offset && offset <= 0x7fffff;
+  if (!(offset & 1) && flags | JIT_RELOC_B)
+    return 0;
+  else
+    return -0x1000000 <= offset && offset <= 0xffffff;
 }
 
 static int32_t
@@ -287,7 +299,7 @@ decode_thumb_jump(uint32_t v)
   ret |= i2 << 21;
   ret |= hi << 11;
   ret |= lo;
-  return ret;
+  return ret << 1;
 }
 
 static const uint32_t thumb_jump_mask = 0xf800d000;
@@ -295,14 +307,15 @@ static const uint32_t thumb_jump_mask = 0xf800d000;
 static uint32_t
 encode_thumb_jump(int32_t v)
 {
-  ASSERT(offset_in_jmp_range(v));
+  ASSERT(offset_in_jmp_range(v, 0));
+  v >>= 1;
   uint32_t s  = !!(v & 0x800000);
   uint32_t i1 = !!(v & 0x400000);
   uint32_t i2 = !!(v & 0x200000);
   uint32_t j1 = s ? i1 : !i1;
   uint32_t j2 = s ? i2 : !i2;
   uint32_t ret = (s<<26)|((v&0x1ff800)<<5)|(j1<<13)|(j2<<11)|(v&0x7ff);
-  ASSERT(decode_thumb_jump(ret) == v);
+  ASSERT(decode_thumb_jump(ret) == v << 1);
   ASSERT((ret & thumb_jump_mask) == 0);
   return ret;
 }
@@ -310,7 +323,13 @@ encode_thumb_jump(int32_t v)
 static uint32_t
 patch_thumb_jump(uint32_t inst, int32_t v)
 {
-  return (inst & thumb_jump_mask) | encode_thumb_jump(v);
+  inst &= thumb_jump_mask;
+  if (!(v & 1)) {
+    ASSERT(inst == THUMB2_BLI || inst == THUMB2_BLXI);
+    v = (v + 2) & ~2;
+    inst = THUMB2_BLXI;
+  }
+  return inst | encode_thumb_jump(v);
 }
 
 static int32_t
@@ -325,15 +344,23 @@ patch_jmp_offset(uint32_t *loc, int32_t v)
   write_wide_thumb(loc, patch_thumb_jump(read_wide_thumb(loc), v));
 }
 
+static void
+patch_veneer_jmp_offset(uint32_t *loc, int32_t v)
+{
+  ASSERT(!(v & 1));
+  patch_jmp_offset(loc, v | 1);
+}
+
 static jit_reloc_t
 emit_thumb_jump(jit_state_t *_jit, uint32_t inst)
 {
   while (1) {
     uint8_t *pc_base = _jit->pc.uc + 4;
-    uint8_t rsh = 1;
+    int32_t off = (uint8_t*)jit_address(_jit) - pc_base;
-    int32_t off = (_jit->pc.uc - pc_base) >> rsh;
+    enum jit_reloc_kind kind = JIT_RELOC_JMP_WITH_VENEER;
-    jit_reloc_t ret =
+    if (inst == THUMB2_B)
-      jit_reloc (_jit, JIT_RELOC_JMP_WITH_VENEER, 0, _jit->pc.uc, pc_base, rsh);
+      kind |= JIT_RELOC_B;
+    jit_reloc_t ret = jit_reloc (_jit, kind, 0, _jit->pc.uc, pc_base, 0);
     uint8_t thumb_jump_width = 24;
     if (add_pending_literal(_jit, ret, thumb_jump_width - 1)) {
       emit_wide_thumb(_jit, patch_thumb_jump(inst, off));
@@ -343,9 +370,12 @@ emit_thumb_jump(jit_state_t *_jit, uint32_t inst)
 }
 
 static int
-offset_in_jcc_range(int32_t v)
+offset_in_jcc_range(int32_t v, int flags)
 {
-  return -0x80000 <= v && v <= 0x7ffff;
+  if (!(v & 1))
+    return 0;
+  else
+    return -0x100000 <= v && v <= 0xfffff;
 }
 
 static int32_t
@@ -363,7 +393,7 @@ decode_thumb_cc_jump(uint32_t v)
   ret |= j1 << 17;
   ret |= hi << 11;
   ret |= lo;
-  return ret;
+  return ret << 1;
 }
 
 static const uint32_t thumb_cc_jump_mask = 0xfbc0d000;
@@ -371,14 +401,15 @@ static const uint32_t thumb_cc_jump_mask = 0xfbc0d000;
 static uint32_t
 encode_thumb_cc_jump(int32_t v)
 {
-  ASSERT(offset_in_jcc_range(v));
+  ASSERT(offset_in_jcc_range(v, 0));
+  v >>= 1;
   uint32_t s  = !!(v & 0x80000);
   uint32_t j2 = !!(v & 0x40000);
   uint32_t j1 = !!(v & 0x20000);
   uint32_t hi = (v >> 11) & 0x3f;
   uint32_t lo = v & 0x7ff;
   uint32_t ret = (s<<26)|(hi << 16)|(j1<<13)|(j2<<11)|lo;
-  ASSERT(decode_thumb_cc_jump(ret) == v);
+  ASSERT(decode_thumb_cc_jump(ret) == v << 1);
   ASSERT((ret & thumb_cc_jump_mask) == 0);
   return ret;
 }
@@ -401,15 +432,21 @@ patch_jcc_offset(uint32_t *loc, int32_t v)
   write_wide_thumb(loc, patch_thumb_cc_jump(read_wide_thumb(loc), v));
 }
 
+static void
+patch_veneer_jcc_offset(uint32_t *loc, int32_t v)
+{
+  ASSERT(!(v & 1));
+  patch_jcc_offset(loc, v | 1);
+}
+
 static jit_reloc_t
 emit_thumb_cc_jump(jit_state_t *_jit, uint32_t inst)
 {
   while (1) {
     uint8_t *pc_base = _jit->pc.uc + 4;
-    uint8_t rsh = 1;
+    int32_t off = (uint8_t*)jit_address(_jit) - pc_base;
-    int32_t off = (_jit->pc.uc - pc_base) >> rsh;
     jit_reloc_t ret =
-      jit_reloc (_jit, JIT_RELOC_JCC_WITH_VENEER, 0, _jit->pc.uc, pc_base, rsh);
+      jit_reloc (_jit, JIT_RELOC_JCC_WITH_VENEER, 0, _jit->pc.uc, pc_base, 0);
     uint8_t thumb_cc_jump_width = 20;
     if (add_pending_literal(_jit, ret, thumb_cc_jump_width - 1)) {
       emit_wide_thumb(_jit, patch_thumb_cc_jump(inst, off));
@@ -1028,12 +1065,6 @@ T2_BLI(jit_state_t *_jit)
   return tb(_jit, THUMB2_BLI);
 }
 
-static jit_reloc_t
-T2_BLXI(jit_state_t *_jit)
-{
-  return tb(_jit, THUMB2_BLXI);
-}
-
 enum dmb_option { DMB_ISH = 0xb };
 static void
 T1_DMB(jit_state_t *_jit, enum dmb_option option)
@@ -2052,7 +2083,7 @@ rshi_u(jit_state_t *_jit, int32_t r0, int32_t r1, jit_word_t i0)
 static void
 jmpr(jit_state_t *_jit, int32_t r0)
 {
-  T1_MOV(_jit, jit_gpr_regno(_PC), r0);
+  T1_BX(_jit, r0);
 }
 
 static jit_reloc_t
@@ -2064,8 +2095,6 @@ jmp(jit_state_t *_jit)
 static void
 jmpi(jit_state_t *_jit, jit_word_t i0)
 {
-  /* Strip thumb bit, if any.  */
-  i0 &= ~1;
   return jit_patch_there(_jit, jmp(_jit), (void*)i0);
 }
 
@@ -2905,10 +2934,7 @@ callr(jit_state_t *_jit, int32_t r0)
 static void
 calli(jit_state_t *_jit, jit_word_t i0)
 {
-  if (i0 & 1)
+  jit_patch_there(_jit, T2_BLI(_jit), (void*)i0);
-    jit_patch_there(_jit, T2_BLI(_jit), (void*)(i0 & ~1));
-  else
-    jit_patch_there(_jit, T2_BLXI(_jit), (void*)i0);
 }
 
 static void
@@ -2990,8 +3016,7 @@ static void
 patch_jmp_without_veneer(jit_state_t *_jit, uint32_t *loc)
 {
   uint8_t *pc_base = ((uint8_t *)loc) + 4;
-  uint8_t rsh = 1;
+  int32_t off = (uint8_t*)jit_address(_jit) - pc_base;
-  int32_t off = (_jit->pc.uc - pc_base) >> rsh;
   write_wide_thumb(loc, THUMB2_B | encode_thumb_jump(off));
 }
 
@@ -3014,11 +3039,10 @@ emit_veneer(jit_state_t *_jit, jit_pointer_t target)
 {
   uint16_t thumb1_ldr = 0x4800;
   int32_t tmp = jit_gpr_regno(JIT_TMP1);
-  int32_t rd = jit_gpr_regno(_PC);
   ASSERT(tmp < 8);
   // Loaded addr is 4 bytes after the LDR, which is aligned, so offset is 0.
   emit_u16(_jit, thumb1_ldr | (tmp << 8));
-  emit_u16(_jit, THUMB_MOV|((_u4(rd)&8)<<4)|(_u4(tmp)<<3)|(rd&7));
+  emit_u16(_jit, THUMB_BX|(_u4(tmp)<<3));
   emit_u32(_jit, (uint32_t) target);
 }
 

libguile/lightening/lightening/lightening.c

@@ -1,5 +1,5 @@
 /*
- * Copyright (C) 2012-2019  Free Software Foundation, Inc.
+ * Copyright (C) 2012-2020  Free Software Foundation, Inc.
  *
  * This file is part of GNU lightning.
  *
@@ -105,11 +105,13 @@ enum guard_pool { GUARD_NEEDED, NO_GUARD_NEEDED };
 static void emit_literal_pool(jit_state_t *_jit, enum guard_pool guard);
 
 static int32_t read_jmp_offset(uint32_t *loc);
-static int offset_in_jmp_range(ptrdiff_t offset);
+static int offset_in_jmp_range(ptrdiff_t offset, int flags);
 static void patch_jmp_offset(uint32_t *loc, ptrdiff_t offset);
+static void patch_veneer_jmp_offset(uint32_t *loc, ptrdiff_t offset);
 static int32_t read_jcc_offset(uint32_t *loc);
-static int offset_in_jcc_range(ptrdiff_t offset);
+static int offset_in_jcc_range(ptrdiff_t offset, int flags);
 static void patch_jcc_offset(uint32_t *loc, ptrdiff_t offset);
+static void patch_veneer_jcc_offset(uint32_t *loc, ptrdiff_t offset);
 static void patch_veneer(uint32_t *loc, jit_pointer_t addr);
 static int32_t read_load_from_pool_offset(uint32_t *loc);
 #endif
@@ -169,7 +171,7 @@ jit_pointer_t
 jit_address(jit_state_t *_jit)
 {
   ASSERT (_jit->start);
-  return _jit->pc.uc;
+  return jit_address_to_function_pointer (_jit->pc.uc);
 }
 
 void
@@ -378,8 +380,11 @@ jit_patch_there(jit_state_t* _jit, jit_reloc_t reloc, jit_pointer_t addr)
   ptrdiff_t diff = (uint8_t*)addr - pc_base;
   ASSERT((diff & ((1 << reloc.rsh) - 1)) == 0);
   diff >>= reloc.rsh;
+#ifdef JIT_NEEDS_LITERAL_POOL
+  int flags = reloc.kind & ~JIT_RELOC_MASK;
+#endif
 
-  switch (reloc.kind)
+  switch (reloc.kind & JIT_RELOC_MASK)
     {
     case JIT_RELOC_ABSOLUTE:
       if (sizeof(diff) == 4)
@@ -404,7 +409,7 @@ jit_patch_there(jit_state_t* _jit, jit_reloc_t reloc, jit_pointer_t addr)
       uint8_t *target = pc_base + (voff << reloc.rsh);
       if (target == loc.uc) {
         // PC still in range to reify direct branch.
-        if (offset_in_jmp_range(diff)) {
+        if (offset_in_jmp_range(diff, flags)) {
           // Target also in range: reify direct branch.
           patch_jmp_offset(loc.ui, diff);
           remove_pending_literal(_jit, reloc);
@@ -423,7 +428,7 @@ jit_patch_there(jit_state_t* _jit, jit_reloc_t reloc, jit_pointer_t addr)
       int32_t voff = read_jcc_offset(loc.ui);
       uint8_t *target = pc_base + (voff << reloc.rsh);
       if (target == loc.uc) {
-        if (offset_in_jcc_range(diff)) {
+        if (offset_in_jcc_range(diff, flags)) {
           patch_jcc_offset(loc.ui, diff);
           remove_pending_literal(_jit, reloc);
         } else {
@@ -1238,8 +1243,8 @@ static void
 reset_literal_pool(jit_state_t *_jit, struct jit_literal_pool *pool)
 {
   pool->deadline = _jit->limit - _jit->start;
-  pool->size = 0;
   memset(pool->entries, 0, sizeof(pool->entries[0]) * pool->size);
+  pool->size = 0;
 }
 
 #define INITIAL_LITERAL_POOL_CAPACITY 12
@@ -1365,13 +1370,13 @@ emit_literal_pool(jit_state_t *_jit, enum guard_pool guard)
     if (_jit->overflow)
       return;
 
-    switch (entry->reloc.kind) {
+    switch (entry->reloc.kind & JIT_RELOC_MASK) {
     case JIT_RELOC_JMP_WITH_VENEER:
-      patch_jmp_offset((uint32_t*) loc, diff);
+      patch_veneer_jmp_offset((uint32_t*) loc, diff);
       emit_veneer(_jit, (void*) (uintptr_t) entry->value);
       break;
     case JIT_RELOC_JCC_WITH_VENEER:
-      patch_jcc_offset((uint32_t*) loc, diff);
+      patch_veneer_jcc_offset((uint32_t*) loc, diff);
       emit_veneer(_jit, (void*) (uintptr_t) entry->value);
       break;
     case JIT_RELOC_LOAD_FROM_POOL:

libguile/lightening/tests/Makefile

@@ -1,5 +1,5 @@
 TESTS=$(sort $(basename $(wildcard *.c)))
-TARGETS=native ia32 aarch64 armv7
+TARGETS ?= native ia32 aarch64 armv7
 
 # Suitable values of cross-compiler variables for Debian:
 #
@@ -17,9 +17,9 @@ TARGETS=native ia32 aarch64 armv7
 #     gcc-aarch64-linux-gnu libc6-dev-arm64-cross libc6:arm64
 #
 CC = gcc
-CC_IA32=guix environment --pure -s i686-linux --ad-hoc gcc-toolchain glibc -- gcc
+CC_IA32=guix environment --pure -s i686-linux --ad-hoc gcc-toolchain -- gcc
-CC_AARCH64=guix environment --pure -s aarch64-linux --ad-hoc gcc-toolchain glibc -- gcc
+CC_AARCH64=guix environment --pure -s aarch64-linux --ad-hoc gcc-toolchain -- gcc
-CC_ARMv7=guix environment --pure -s armhf-linux --ad-hoc gcc-toolchain glibc -- gcc
+CC_ARMv7=guix environment --pure -s armhf-linux --ad-hoc gcc-toolchain -- gcc
 CFLAGS = -Wall -O0 -g
 
 all: $(foreach TARGET,$(TARGETS),$(addprefix test-$(TARGET)-,$(TESTS)))

libguile/lightening/tests/jmpi_local.c

@@ -0,0 +1,25 @@
+#include "test.h"
+
+static void
+run_test(jit_state_t *j, uint8_t *arena_base, size_t arena_size)
+{
+  jit_begin(j, arena_base, arena_size);
+
+  jit_reloc_t r = jit_jmp (j);
+  jit_reti (j, 0);
+  jit_pointer_t addr = jit_address (j);
+  jit_reti (j, 1);
+  jit_patch_here (j, r);
+  jit_jmpi (j, addr);
+  jit_reti (j, 2);
+
+  int (*f)(void) = jit_end(j, NULL);
+
+  ASSERT(f() == 1);
+}
+
+int
+main (int argc, char *argv[])
+{
+  return main_helper(argc, argv, run_test);
+}

libguile/lightening/tests/movi.c

@@ -0,0 +1,22 @@
+#include "test.h"
+
+static void
+run_test(jit_state_t *j, uint8_t *arena_base, size_t arena_size)
+{
+  jit_begin(j, arena_base, arena_size);
+  size_t align = jit_enter_jit_abi(j, 0, 0, 0);
+
+  jit_movi(j, JIT_R0, 0xa500a500);
+  jit_leave_jit_abi(j, 0, 0, align);
+  jit_retr(j, JIT_R0);
+
+  jit_uword_t (*f)(void) = jit_end(j, NULL);
+
+  ASSERT(f() == 0xa500a500);
+}
+
+int
+main (int argc, char *argv[])
+{
+  return main_helper(argc, argv, run_test);
+}

libguile/read.c

@@ -704,7 +704,7 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts)
                 break;
             bad_escaped:
               scm_i_input_error (FUNC_NAME, port,
-                                 "illegal character in escape sequence: ~S",
+                                 "invalid character in escape sequence: ~S",
                                  scm_list_1 (SCM_MAKE_CHAR (c)));
             }
         }

libguile/srfi-1.c

@@ -1,6 +1,6 @@
 /* srfi-1.c --- SRFI-1 procedures for Guile
 
-   Copyright 1995-1997,2000-2003,2005-2006,2008-2011,2013-2014,2018
+   Copyright 1995-1997,2000-2003,2005-2006,2008-2011,2013-2014,2018,2020
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -575,47 +575,6 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0,
 }
 #undef FUNC_NAME
 
-
-SCM_DEFINE (scm_srfi1_find, "find", 2, 0, 0,
-            (SCM pred, SCM lst),
-	    "Return the first element of @var{lst} which satisfies the\n"
-	    "predicate @var{pred}, or return @code{#f} if no such element is\n"
-	    "found.")
-#define FUNC_NAME s_scm_srfi1_find
-{
-  SCM_VALIDATE_PROC (SCM_ARG1, pred);
-
-  for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
-    {
-      SCM elem = SCM_CAR (lst);
-      if (scm_is_true (scm_call_1 (pred, elem)))
-        return elem;
-    }
-  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
-
-  return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0,
-            (SCM pred, SCM lst),
-	    "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
-	    "predicate @var{pred}, or return @code{#f} if no such element is\n"
-	    "found.")
-#define FUNC_NAME s_scm_srfi1_find_tail
-{
-  SCM_VALIDATE_PROC (SCM_ARG1, pred);
-
-  for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
-    if (scm_is_true (scm_call_1 (pred, SCM_CAR (lst))))
-      return lst;
-  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
-
-  return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
 SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
             (SCM lst),
 	    "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
@@ -751,37 +710,6 @@ SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1,
 }
 #undef FUNC_NAME
 
-
-SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
-	    (SCM key, SCM alist, SCM pred),
-	    "Behaves like @code{assq} but uses third argument @var{pred}\n"
-	    "for key comparison.  If @var{pred} is not supplied,\n"
-	    "@code{equal?} is used.  (Extended from R5RS.)\n")
-#define FUNC_NAME s_scm_srfi1_assoc
-{
-  SCM ls = alist;
-  scm_t_trampoline_2 equal_p;
-  if (SCM_UNBNDP (pred))
-    equal_p = equal_trampoline;
-  else
-    {
-      SCM_VALIDATE_PROC (SCM_ARG3, pred);
-      equal_p = scm_call_2;
-    }
-  for(; scm_is_pair (ls); ls = SCM_CDR (ls)) 
-    {
-      SCM tmp = SCM_CAR (ls);
-      SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
-		       "association list");
-      if (scm_is_true (equal_p (pred, key, SCM_CAR (tmp))))
-	return tmp;
-    }
-  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
-		   "association list");
-  return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
 SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
 	    (SCM pred, SCM list),
 	    "Partition the elements of @var{list} with predicate @var{pred}.\n"

libguile/srfi-1.h

@@ -1,5 +1,5 @@
 /* srfi-1.h --- SRFI-1 procedures for Guile
-   Copyright 2002-2003,2005-2006,2010-2011,2018
+   Copyright 2002-2003,2005-2006,2010-2011,2018,2020
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -33,12 +33,9 @@ SCM_INTERNAL SCM scm_srfi1_delete (SCM x, SCM lst, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_delete_x (SCM x, SCM lst, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred);
-SCM_INTERNAL SCM scm_srfi1_find (SCM pred, SCM lst);
-SCM_INTERNAL SCM scm_srfi1_find_tail (SCM pred, SCM lst);
 SCM_INTERNAL SCM scm_srfi1_length_plus (SCM lst);
 SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest);
 SCM_INTERNAL SCM scm_srfi1_list_copy (SCM lst);
-SCM_INTERNAL SCM scm_srfi1_assoc (SCM key, SCM alist, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list);
 SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list);
 SCM_INTERNAL SCM scm_srfi1_remove (SCM pred, SCM list);

libguile/srfi-13.c

@@ -382,11 +382,12 @@ SCM_SYMBOL (scm_sym_prefix, "prefix");
 
 SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
             (SCM ls, SCM delimiter, SCM grammar),
-	    "Append the string in the string list @var{ls}, using the string\n"
+            "Append the string in the string list @var{ls}, using the string\n"
-	    "@var{delimiter} as a delimiter between the elements of @var{ls}.\n"
+            "@var{delimiter} as a delimiter between the elements of @var{ls}.\n"
-	    "@var{grammar} is a symbol which specifies how the delimiter is\n"
+            "@var{delimiter} defaults to @w{@samp{ }}, that is, strings in @var{ls}\n"
-	    "placed between the strings, and defaults to the symbol\n"
+            "are appended with the space character in between them.  @var{grammar} is\n"
-	    "@code{infix}.\n"
+            "a symbol which specifies how the delimiter is placed between the\n"
+            "strings, and defaults to the symbol @code{infix}.\n"
 	    "\n"
 	    "@table @code\n"
 	    "@item infix\n"

module/ice-9/popen.scm

@@ -99,13 +99,28 @@ process (based on pipes) is created and returned.  @var{mode} specifies
 whether an input, an output or an input-output port to the process is
 created: it should be the value of @code{OPEN_READ}, @code{OPEN_WRITE}
 or @code{OPEN_BOTH}."
+  (define (unbuffered port)
+    (setvbuf port 'none)
+    port)
+
+  (define (fdes-pair ports)
+    (and ports
+         (cons (port->fdes (car ports)) (port->fdes (cdr ports)))))
+
   (let* ((from (and (or (string=? mode OPEN_READ)
-                        (string=? mode OPEN_BOTH)) (pipe->fdes)))
+                        (string=? mode OPEN_BOTH))
+                    (pipe)))
          (to (and (or (string=? mode OPEN_WRITE)
-                      (string=? mode OPEN_BOTH)) (pipe->fdes)))
+                      (string=? mode OPEN_BOTH))
-         (pid (piped-process command args from to)))
+                  (pipe)))
-    (values (and from (fdes->inport (car from)))
+         (pid (piped-process command args
-            (and to (fdes->outport (cdr to))) pid)))
+                             (fdes-pair from)
+                             (fdes-pair to))))
+    ;; The original 'open-process' procedure would return unbuffered
+    ;; ports; do the same here.
+    (values (and from (unbuffered (car from)))
+            (and to (unbuffered (cdr to)))
+            pid)))
 
 (define (open-pipe* mode command . args)
   "Executes the program @var{command} with optional arguments
@@ -200,10 +215,10 @@ information on how to interpret this value."
   (open-pipe command OPEN_BOTH))
 
 (define (pipeline commands)
-  "Execute a pipeline of @var(commands) -- where each command is a list of a
+  "Execute a pipeline of @var{commands}, where each command is a list of a
-program and its arguments as strings -- returning an input port to the
+program and its arguments as strings, returning an input port to the
 end of the pipeline, an output port to the beginning of the pipeline and
-a list of PIDs of the processes executing the @var(commands)."
+a list of PIDs of the processes executing the @var{commands}."
   (let* ((to (pipe->fdes))
          (pipes (map (lambda _ (pipe->fdes)) commands))
 	 (pipeline (fold (lambda (from proc prev)

module/language/cps/cse.scm

@@ -551,7 +551,11 @@ false.  It could be that both true and false proofs are available."
                       (prune-successors analysis label (term-successors term))))
              ((trivial-intset preds)
               => (lambda (pred)
-                   (match (intmap-ref out pred)
+                   (match (and (< pred label) (intmap-ref out pred))
+                     (#f
+                      ;; Orphan loop; branch folding must have removed
+                      ;; entry.  Could still be alive though.
+                      (visit-term-normally))
                      (($ $kargs names' vars' ($ $continue _ _ ($ $values vals)))
                       ;; Substitute dominating definitions, and try to elide the
                       ;; predecessor entirely.
@@ -583,7 +587,7 @@ false.  It could be that both true and false proofs are available."
                          ;; those as well.
                          (add-auxiliary-definitions! pred vars substs term-key)))
                       (visit-term-normally))
-                     (_
+                     ((or ($ $kclause) ($ $kreceive))
                       (visit-term-normally)))))
              (else
               (visit-term-normally)))))))

module/language/tree-il/compile-cps.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2015,2017-2019 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015,2017-2020 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
@@ -895,37 +895,32 @@
     ($ (ensure-bytevector klen src op pred bv))))
 
 (define (bytevector-ref-converter scheme-name ptr-op width kind)
-  (define tag
+  (define (tag cps k src val)
     (match kind
       ('unsigned
        (if (< (ash 1 (* width 8)) (target-most-positive-fixnum))
-           (lambda (cps k src val)
+           (with-cps cps
-             (with-cps cps
+             (letv s)
-               (letv s)
+             (letk kcvt
-               (letk kcvt
+                   ($kargs ('s) (s)
-                     ($kargs ('s) (s)
+                           ($continue k src ($primcall 'tag-fixnum #f (s)))))
-                       ($continue k src ($primcall 'tag-fixnum #f (s)))))
+             (build-term
-               (build-term
+               ($continue kcvt src ($primcall 'u64->s64 #f (val)))))
-                 ($continue kcvt src ($primcall 'u64->s64 #f (val))))))
+           (with-cps cps
-           (lambda (cps k src val)
+             (build-term
-             (with-cps cps
+               ($continue k src ($primcall 'u64->scm #f (val)))))))
-               (build-term
-                 ($continue k src ($primcall 'u64->scm #f (val))))))))
       ('signed
        (if (< (ash 1 (* width 8)) (target-most-positive-fixnum))
-           (lambda (cps k src val)
+           (with-cps cps
-             (with-cps cps
+             (build-term
-               (build-term
+               ($continue k src ($primcall 'tag-fixnum #f (val)))))
-                 ($continue k src ($primcall 'tag-fixnum #f (val))))))
+           (with-cps cps
-           (lambda (cps k src val)
+             (build-term
-             (with-cps cps
+               ($continue k src ($primcall 's64->scm #f (val)))))))
-               (build-term
-                 ($continue k src ($primcall 's64->scm #f (val))))))))
       ('float
-       (lambda (cps k src val)
+       (with-cps cps
-         (with-cps cps
+         (build-term
-           (build-term
+           ($continue k src ($primcall 'f64->scm #f (val))))))))
-             ($continue k src ($primcall 'f64->scm #f (val)))))))))
   (lambda (cps k src op param bv idx)
     (prepare-bytevector-access
      cps src scheme-name 'bytevector? bv idx width
@@ -962,9 +957,9 @@
       (build-term
         ($branch k' kbad src 'imm-s64-< hi (sval)))))
   (define (integer-unboxer lo hi)
-    (cond
+    (lambda (cps src val have-val)
-     ((<= hi (target-most-positive-fixnum))
+      (cond
-      (lambda (cps src val have-val)
+       ((<= hi (target-most-positive-fixnum))
         (let ((have-val (if (zero? lo)
                             (lambda (cps s)
                               (with-cps cps
@@ -989,17 +984,15 @@
                   ($kargs () ()
                     ($continue klo src ($primcall 'untag-fixnum #f (val)))))
             (build-term
-              ($branch kbad kuntag src 'fixnum? #f (val)))))))
+              ($branch kbad kuntag src 'fixnum? #f (val))))))
-     ((zero? lo)
+       ((zero? lo)
-      (lambda (cps src val have-val)
         (with-cps cps
           (letv u)
           (let$ body (limit-urange src val u hi have-val))
           (letk khi ($kargs ('u) (u) ,body))
           (build-term
-            ($continue khi src ($primcall 'scm->u64 #f (val)))))))
+            ($continue khi src ($primcall 'scm->u64 #f (val))))))
-     (else
+       (else
-      (lambda (cps src val have-val)
         (with-cps cps
           (letv s)
           (let$ body (limit-srange src val s lo hi have-val))

module/srfi/srfi-1.scm

@@ -1,6 +1,6 @@
 ;;; srfi-1.scm --- List Library
 
-;; 	Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2014 Free Software Foundation, Inc.
+;; 	Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2014, 2020 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
@@ -720,6 +720,28 @@ the list returned."
 
 ;;; Searching
 
+(define (find pred lst)
+  "Return the first element of @var{lst} that satisfies the predicate
+@var{pred}, or return @code{#f} if no such element is found."
+  (check-arg procedure? pred find)
+  (let loop ((lst lst))
+    (and (not (null? lst))
+         (let ((head (car lst)))
+           (if (pred head)
+               head
+               (loop (cdr lst)))))))
+
+(define (find-tail pred lst)
+  "Return the first pair of @var{lst} whose @sc{car} satisfies the
+predicate @var{pred}, or return @code{#f} if no such element is found."
+  (check-arg procedure? pred find)
+  (let loop ((lst lst))
+    (and (not (null? lst))
+         (let ((head (car lst)))
+           (if (pred head)
+               lst
+               (loop (cdr lst)))))))
+
 (define (take-while pred ls)
   "Return a new list which is the longest initial prefix of LS whose
 elements all satisfy the predicate PRED."
@@ -901,6 +923,23 @@ and those making the associations."
 
 ;;; Delete / assoc / member
 
+(define* (assoc key alist #:optional (= equal?))
+  "Behaves like @code{assq} but uses third argument @var{pred} for key
+comparison.  If @var{pred} is not supplied, @code{equal?} is
+used.  (Extended from R5RS.)"
+  (cond
+   ((eq? = eq?) (assq key alist))
+   ((eq? = eqv?) (assv key alist))
+   (else
+    (check-arg procedure? = assoc)
+    (let loop ((alist alist))
+      (and (pair? alist)
+           (let ((item (car alist)))
+             (check-arg pair? item assoc)
+             (if (= key (car item))
+                 item
+                 (loop (cdr alist)))))))))
+
 (define* (member x ls #:optional (= equal?))
   (cond
    ;; This might be performance-sensitive, so punt on the check here,

module/texinfo.scm

@@ -1,6 +1,6 @@
 ;;;; (texinfo) -- parsing of texinfo into SXML
 ;;;;
-;;;; 	Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014  Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2020  Free Software Foundation, Inc.
 ;;;;    Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
 ;;;;    Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com>
 ;;;;
@@ -211,6 +211,7 @@ lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS},
     (sansserif          INLINE-TEXT)
     (slanted            INLINE-TEXT)
     (t                  INLINE-TEXT)
+    (w                  INLINE-TEXT)
 
     ;; Inline args commands
     (value              INLINE-ARGS . (key))
@@ -382,7 +383,7 @@ Examples:
 ;; The % is for arguments
 (define (space-significant? command)
   (memq command
-        '(example smallexample verbatim lisp smalllisp menu %)))
+        '(example smallexample verbatim lisp smalllisp menu w %)))
 
 ;; Like a DTD for texinfo
 (define (command-spec command)

module/texinfo/html.scm

@@ -1,6 +1,6 @@
 ;;;; (texinfo html) -- translating stexinfo into shtml
 ;;;;
-;;;; 	Copyright (C) 2009, 2010, 2011  Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2009, 2010, 2011, 2020  Free Software Foundation, Inc.
 ;;;;    Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
@@ -202,6 +202,7 @@ name, @code{#}, and the node name."
     (*fragment*   div) ;; should be ok
 
     (asis         span)
+    (w            span (@ (class "verbatim")))
     (bold         b)
     (i            i)
     (sample       samp)

module/web/uri.scm

@@ -1,6 +1,6 @@
 ;;;; (web uri) --- URI manipulation tools
 ;;;;
-;;;; Copyright (C) 1997,2001,2002,2010,2011,2012,2013,2014,2019 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997,2001,2002,2010,2011,2012,2013,2014,2019,2020 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
@@ -188,7 +188,7 @@ for ‘build-uri’ except there is no scheme."
 (define ipv4-regexp
   (make-regexp (string-append "^([" digits ".]+)$")))
 (define ipv6-regexp
-  (make-regexp (string-append "^([" hex-digits ":.]+)$")))
+  (make-regexp (string-append "^([" hex-digits "]*:[" hex-digits ":.]+)$")))
 (define domain-label-regexp
   (make-regexp
    (string-append "^[" letters digits "]"

test-suite/tests/popen.test

@@ -196,6 +196,29 @@ exec 2>~a; read REPLY"
             (close-pipe port)
             result))))))
 
+
+ (with-test-prefix "open-pipe*"
+
+   (pass-if-equal "OPEN_BOTH"
+       '(0 (good!))
+     ;; This test ensures that the ports that underlie the read/write
+     ;; port are unbuffered.  If they were buffered, the child process
+     ;; would wait in 'read' forever.
+     (let ((pipe (open-pipe* OPEN_BOTH "guile" "-c"
+                             (object->string
+                              '(begin
+                                 (setvbuf (current-output-port) 'line)
+                                 (write '(hello!))
+                                 (newline)
+                                 (let ((greeting (read)))
+                                   (write '(good!))))))))
+       (setvbuf pipe 'line)
+       (let ((return (read pipe)))
+         (write '(hi!) pipe)
+         (newline pipe)
+         (let ((last (read pipe)))
+           (list (close-pipe pipe) last))))))
+
  ;;
  ;; close-pipe
  ;;

test-suite/tests/reader.test

@@ -1,6 +1,6 @@
 ;;;; reader.test --- Reader test.    -*- coding: iso-8859-1; mode: scheme -*-
 ;;;;
-;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2013-2015
+;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2013-2015, 2020
 ;;;;   Free Software Foundation, Inc.
 ;;;;
 ;;;; Jim Blandy <jimb@red-bean.com>
@@ -40,8 +40,8 @@
   (cons 'read-error "end of file in string constant$"))
 (define exception:eof-in-symbol
   (cons 'read-error "end of file while reading symbol$"))
-(define exception:illegal-escape
+(define exception:invalid-escape
-  (cons 'read-error "illegal character in escape sequence: .*$"))
+  (cons 'read-error "invalid character in escape sequence: .*$"))
 (define exception:missing-expression
   (cons 'read-error "no expression after #;"))
 (define exception:mismatched-paren
@@ -234,8 +234,8 @@
   (pass-if-exception "eof in string"
     exception:eof-in-string
     (read-string "\"the string that never ends"))
-  (pass-if-exception "illegal escape in string"
+  (pass-if-exception "invalid escape in string"
-    exception:illegal-escape
+    exception:invalid-escape
     (read-string "\"some string \\???\"")))
 
 
@@ -304,31 +304,31 @@
 
   (with-test-prefix "r6rs-hex-escapes"
       (pass-if-exception "non-hex char in two-digit hex-escape"
-      exception:illegal-escape
+      exception:invalid-escape
       (with-read-options '(r6rs-hex-escapes)
         (lambda ()
           (with-input-from-string "\"\\x0g;\"" read))))
 
     (pass-if-exception "non-hex char in four-digit hex-escape"
-      exception:illegal-escape
+      exception:invalid-escape
       (with-read-options '(r6rs-hex-escapes)
         (lambda ()
           (with-input-from-string "\"\\x000g;\"" read))))
 
     (pass-if-exception "non-hex char in six-digit hex-escape"
-      exception:illegal-escape
+      exception:invalid-escape
       (with-read-options '(r6rs-hex-escapes)
         (lambda ()
           (with-input-from-string "\"\\x00000g;\"" read))))
 
     (pass-if-exception "no semicolon at termination of one-digit hex-escape"
-      exception:illegal-escape
+      exception:invalid-escape
       (with-read-options '(r6rs-hex-escapes)
         (lambda ()
           (with-input-from-string "\"\\x0\"" read))))
 
     (pass-if-exception "no semicolon at termination of three-digit hex-escape"
-      exception:illegal-escape
+      exception:invalid-escape
       (with-read-options '(r6rs-hex-escapes)
         (lambda ()
           (with-input-from-string "\"\\x000\"" read))))

test-suite/tests/strings.test

@@ -1,7 +1,7 @@
 ;;;; strings.test --- test suite for Guile's string functions    -*- scheme -*-
 ;;;; Jim Blandy <jimb@red-bean.com> --- August 1999
 ;;;;
-;;;; Copyright (C) 1999,2001,2004-2006,2008-2011,2013,2015,2018
+;;;; Copyright (C) 1999,2001,2004-2006,2008-2011,2013,2015,2018,2020
 ;;;;   Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -25,8 +25,8 @@
 
 (define exception:read-only-string
   (cons 'misc-error "^string is read-only"))
-(define exception:illegal-escape
+(define exception:invalid-escape
-  (cons 'read-error "illegal character in escape sequence"))
+  (cons 'read-error "invalid character in escape sequence"))
 
 ;; Create a string from integer char values, eg. (string-ints 65) => "A"
 (define (string-ints . args)
@@ -197,27 +197,27 @@
 (with-test-prefix "escapes"
 
   (pass-if-exception "non-hex char in two-digit hex-escape"
-    exception:illegal-escape                     
+    exception:invalid-escape                     
     (with-input-from-string "\"\\x0g\"" read))
 
   (pass-if-exception "non-hex char in four-digit hex-escape"
-    exception:illegal-escape                     
+    exception:invalid-escape                     
     (with-input-from-string "\"\\u000g\"" read))
 
   (pass-if-exception "non-hex char in six-digit hex-escape"
-    exception:illegal-escape                     
+    exception:invalid-escape                     
     (with-input-from-string "\"\\U00000g\"" read))
 
   (pass-if-exception "premature termination of two-digit hex-escape"
-    exception:illegal-escape                     
+    exception:invalid-escape                     
     (with-input-from-string "\"\\x0\"" read))
 
   (pass-if-exception "premature termination of four-digit hex-escape"
-    exception:illegal-escape                     
+    exception:invalid-escape                     
     (with-input-from-string "\"\\u000\"" read))
 
   (pass-if-exception "premature termination of six-digit hex-escape"
-    exception:illegal-escape                     
+    exception:invalid-escape                     
     (with-input-from-string "\"\\U00000\"" read))
 
   (pass-if "extra hex digits ignored for two-digit hex escape"

test-suite/tests/texinfo.test

@@ -1,6 +1,6 @@
 ;;;; texinfo.test                 -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014  Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2020  Free Software Foundation, Inc.
 ;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com>
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -221,6 +221,8 @@
              '((para (code "abc " (code)))))
   (test-body "@code{ arg               }"
              '((para (code "arg"))))
+  (test-body "@w{ arg with  spaces   }"
+             '((para (w " arg with  spaces   "))))
 
   (test-body "@acronym{GNU}"
              '((para (acronym (% (acronym "GNU"))))))

test-suite/tests/web-uri.test

@@ -1,6 +1,6 @@
 ;;;; web-uri.test --- URI library          -*- mode: scheme; coding: utf-8; -*-
 ;;;;
-;;;; 	Copyright (C) 2010-2012, 2014, 2017, 2019 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2010-2012, 2014, 2017, 2019, 2020 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
@@ -179,6 +179,13 @@
            #:port 22
            #:path "/baz"))
 
+  (pass-if-equal "xyz://abc/x/y/z"         ;<https://bugs.gnu.org/40582>
+      (list 'xyz "abc" "/x/y/z")
+    (let ((uri (string->uri "xyz://abc/x/y/z")))
+      (list (uri-scheme uri)
+            (uri-host uri)
+            (uri-path uri))))
+
   (pass-if "http://bad.host.1"
     (not (string->uri "http://bad.host.1")))