Merge.
This commit is contained in:
Dale Mellor
commit
2019f2c12d
33 changed files with 393 additions and 231 deletions
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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_REVISION=1
|
||||
LIBGUILE_INTERFACE_AGE=1
|
||||
LIBGUILE_INTERFACE_CURRENT=3
|
||||
LIBGUILE_INTERFACE_REVISION=0
|
||||
LIBGUILE_INTERFACE_AGE=2
|
||||
LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}"
|
||||
|
|
|
|||
43
NEWS
43
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
placed between the strings, and defaults to the symbol
|
||||
@code{infix}.
|
||||
@var{delimiter} defaults to @w{@samp{ }}, that is, strings in @var{ls}
|
||||
are appended with the space character in between them. @var{grammar} is
|
||||
a symbol which specifies how the delimiter is placed between the
|
||||
strings, and defaults to the symbol @code{infix}.
|
||||
|
||||
@table @code
|
||||
@item infix
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
@code{bytes}, either the symbol @code{*} or a pair of integers,
|
||||
indicating the byte rage, and either @code{*} or an integer, for the
|
||||
instance length. Used to indicate that a response only includes part of
|
||||
a resource.
|
||||
Range specification as a list of three elements: the symbol
|
||||
@code{bytes}, either the symbol @code{*} or a pair of integers
|
||||
indicating the byte range, and either @code{*} or an integer indicating
|
||||
the instance length. Used to indicate that a response only includes
|
||||
part of a resource.
|
||||
@example
|
||||
(parse-header 'content-range "bytes 10-20/*")
|
||||
@result{} (bytes (10 . 20) *)
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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_PATCHABLE_INSTRUCTION(jcc, simm19, JCC_WITH_VENEER, 2);
|
||||
#define DEFINE_PATCHABLE_INSTRUCTIONS(name, kind, RELOC, rsh) \
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
# define rotate_left(v, n) (v << n | v >> (32 - n))
|
||||
static uint32_t
|
||||
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 = (_jit->pc.uc - pc_base) >> rsh;
|
||||
jit_reloc_t ret =
|
||||
jit_reloc (_jit, JIT_RELOC_JMP_WITH_VENEER, 0, _jit->pc.uc, pc_base, rsh);
|
||||
int32_t off = (uint8_t*)jit_address(_jit) - pc_base;
|
||||
enum jit_reloc_kind kind = JIT_RELOC_JMP_WITH_VENEER;
|
||||
if (inst == THUMB2_B)
|
||||
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 = (_jit->pc.uc - pc_base) >> rsh;
|
||||
int32_t off = (uint8_t*)jit_address(_jit) - pc_base;
|
||||
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 & ~1));
|
||||
else
|
||||
jit_patch_there(_jit, T2_BLXI(_jit), (void*)i0);
|
||||
jit_patch_there(_jit, T2_BLI(_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 = (_jit->pc.uc - pc_base) >> rsh;
|
||||
int32_t off = (uint8_t*)jit_address(_jit) - pc_base;
|
||||
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);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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_AARCH64=guix environment --pure -s aarch64-linux --ad-hoc gcc-toolchain glibc -- gcc
|
||||
CC_ARMv7=guix environment --pure -s armhf-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 -- 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)))
|
||||
|
|
|
|||
25
libguile/lightening/tests/jmpi_local.c
Normal file
25
libguile/lightening/tests/jmpi_local.c
Normal file
|
|
@ -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);
|
||||
}
|
||||
22
libguile/lightening/tests/movi.c
Normal file
22
libguile/lightening/tests/movi.c
Normal file
|
|
@ -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);
|
||||
}
|
||||
|
|
@ -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)));
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -384,9 +384,10 @@ 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"
|
||||
"@var{delimiter} as a delimiter between the elements of @var{ls}.\n"
|
||||
"@var{grammar} is a symbol which specifies how the delimiter is\n"
|
||||
"placed between the strings, and defaults to the symbol\n"
|
||||
"@code{infix}.\n"
|
||||
"@var{delimiter} defaults to @w{@samp{ }}, that is, strings in @var{ls}\n"
|
||||
"are appended with the space character in between them. @var{grammar} is\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"
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
(pid (piped-process command args from to)))
|
||||
(values (and from (fdes->inport (car from)))
|
||||
(and to (fdes->outport (cdr to))) pid)))
|
||||
(string=? mode OPEN_BOTH))
|
||||
(pipe)))
|
||||
(pid (piped-process command args
|
||||
(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
|
||||
program and its arguments as strings -- returning an input port to the
|
||||
"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
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(letv s)
|
||||
(letk kcvt
|
||||
($kargs ('s) (s)
|
||||
($continue k src ($primcall 'tag-fixnum #f (s)))))
|
||||
(build-term
|
||||
($continue kcvt src ($primcall 'u64->s64 #f (val))))))
|
||||
(lambda (cps k src val)
|
||||
($continue kcvt src ($primcall 'u64->s64 #f (val)))))
|
||||
(with-cps cps
|
||||
(build-term
|
||||
($continue k src ($primcall 'u64->scm #f (val))))))))
|
||||
($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
|
||||
(build-term
|
||||
($continue k src ($primcall 'tag-fixnum #f (val))))))
|
||||
(lambda (cps k src val)
|
||||
($continue k src ($primcall 'tag-fixnum #f (val)))))
|
||||
(with-cps cps
|
||||
(build-term
|
||||
($continue k src ($primcall 's64->scm #f (val))))))))
|
||||
($continue k src ($primcall 's64->scm #f (val)))))))
|
||||
('float
|
||||
(lambda (cps k src val)
|
||||
(with-cps cps
|
||||
(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)
|
||||
(lambda (cps src val have-val)
|
||||
(cond
|
||||
((<= hi (target-most-positive-fixnum))
|
||||
(lambda (cps src val have-val)
|
||||
(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)
|
||||
(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
|
||||
(lambda (cps src val have-val)
|
||||
(with-cps cps
|
||||
(letv s)
|
||||
(let$ body (limit-srange src val s lo hi have-val))
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 "]"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(cons 'read-error "illegal character in escape sequence: .*$"))
|
||||
(define exception:invalid-escape
|
||||
(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"
|
||||
exception:illegal-escape
|
||||
(pass-if-exception "invalid escape in string"
|
||||
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))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(cons 'read-error "illegal character in escape sequence"))
|
||||
(define exception:invalid-escape
|
||||
(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"
|
||||
|
|
|
|||
|
|
@ -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"))))))
|
||||
|
|
|
|||
|
|
@ -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")))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue