[COMMIT] Transform #'princ to #'write-sequence at compile time if appropriate.
10 years, 10 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1387708593 0
# Node ID 4004c3266c09888a9935242a462beb3fb28e02a3
# Parent 7a538e1a4676a2229b4f1806dfa26725226f0ba7
Transform #'princ to #'write-sequence at compile time if appropriate.
lisp/ChangeLog addition:
2013-12-22 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el:
* cl-macs.el (princ): New compiler macro.
Transform #'princ to #'write-sequence if we can determine at
compile time that it is being passed a string. Initialising the
printer is expensive enough, but much of our code took this
approach because #'write-sequence wasn't available.
diff -r 7a538e1a4676 -r 4004c3266c09 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Dec 19 18:13:11 2013 +0000
+++ b/lisp/ChangeLog Sun Dec 22 10:36:33 2013 +0000
＠＠ -1,3 +1,12 ＠＠
+2013-12-22 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el:
+ * cl-macs.el (princ): New compiler macro.
+ Transform #'princ to #'write-sequence if we can determine at
+ compile time that it is being passed a string. Initialising the
+ printer is expensive enough, but much of our code took this
+ approach because #'write-sequence wasn't available.
+
2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net>
* simple.el (blink-matching-open):
diff -r 7a538e1a4676 -r 4004c3266c09 lisp/cl-macs.el
--- a/lisp/cl-macs.el Thu Dec 19 18:13:11 2013 +0000
+++ b/lisp/cl-macs.el Sun Dec 22 10:36:33 2013 +0000
＠＠ -3911,6 +3911,28 ＠＠
(list* 'intersection (pop cl-keys) (pop cl-keys) :stable t cl-keys)
form))
+(define-compiler-macro princ (&whole form object &optional stream)
+ "When passing `princ' a string, call `write-sequence' instead.
+
+This avoids the resource- and time-intensive initialization of the printer,
+and functions equivalently. Such code will not run on 21.4, but 21.4 will
+not normally encounter it, and the error message will be clear enough (that
+`write-sequence' has a void function definition) in the odd event that it
+does."
+ (cond ((not (<= 2 (length form) 3))
+ form)
+ ((or (stringp object)
+ (member (car-safe object)
+ '(buffer-string buffer-substring concat format gettext
+ key-description make-string mapconcat
+ substitute-command-keys substring-no-properties
+ symbol-name text-char-description string)))
+ (cons 'write-sequence (cdr form)))
+ ((member (car-safe object) '(substring subseq))
+ `(write-sequence ,(nth 1 object) ,stream :start ,(nth 2 object)
+ ,＠(if (nth 3 object) `((:end ,(nth 3 object))))))
+ (t form)))
+
(map nil
#'(lambda (function)
;; There are byte codes for the two-argument versions of these
--
‘Liston operated so fast that he once accidentally amputated an assistant’s
fingers along with a patient’s leg, […] The patient and the assistant both
died of sepsis, and a spectator reportedly died of shock, resulting in the
only known procedure with a 300% mortality.’ (Atul Gawande, NEJM, 2012)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit/XEmacs: kehoea: Transform #'princ to #'write-sequence at compile time if appropriate.
10 years, 10 months
Bitbucket
Bitbucket
1 new commit in XEmacs:
https://bitbucket.org/xemacs/xemacs/commits/4004c3266c09/
Changeset: 4004c3266c09
User: kehoea
Date: 2013-12-22 11:36:33
Summary: Transform #'princ to #'write-sequence at compile time if appropriate.
lisp/ChangeLog addition:
2013-12-22 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el:
* cl-macs.el (princ): New compiler macro.
Transform #'princ to #'write-sequence if we can determine at
compile time that it is being passed a string. Initialising the
printer is expensive enough, but much of our code took this
approach because #'write-sequence wasn't available.
Affected #: 2 files
diff -r 7a538e1a4676a2229b4f1806dfa26725226f0ba7 -r 4004c3266c09888a9935242a462beb3fb28e02a3 lisp/ChangeLog
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
＠＠ -1,3 +1,12 ＠＠
+2013-12-22 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el:
+ * cl-macs.el (princ): New compiler macro.
+ Transform #'princ to #'write-sequence if we can determine at
+ compile time that it is being passed a string. Initialising the
+ printer is expensive enough, but much of our code took this
+ approach because #'write-sequence wasn't available.
+
2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net>
* simple.el (blink-matching-open):
diff -r 7a538e1a4676a2229b4f1806dfa26725226f0ba7 -r 4004c3266c09888a9935242a462beb3fb28e02a3 lisp/cl-macs.el
--- a/lisp/cl-macs.el
+++ b/lisp/cl-macs.el
＠＠ -3911,6 +3911,28 ＠＠
(list* 'intersection (pop cl-keys) (pop cl-keys) :stable t cl-keys)
form))
+(define-compiler-macro princ (&whole form object &optional stream)
+ "When passing `princ' a string, call `write-sequence' instead.
+
+This avoids the resource- and time-intensive initialization of the printer,
+and functions equivalently. Such code will not run on 21.4, but 21.4 will
+not normally encounter it, and the error message will be clear enough (that
+`write-sequence' has a void function definition) in the odd event that it
+does."
+ (cond ((not (<= 2 (length form) 3))
+ form)
+ ((or (stringp object)
+ (member (car-safe object)
+ '(buffer-string buffer-substring concat format gettext
+ key-description make-string mapconcat
+ substitute-command-keys substring-no-properties
+ symbol-name text-char-description string)))
+ (cons 'write-sequence (cdr form)))
+ ((member (car-safe object) '(substring subseq))
+ `(write-sequence ,(nth 1 object) ,stream :start ,(nth 2 object)
+ ,＠(if (nth 3 object) `((:end ,(nth 3 object))))))
+ (t form)))
+
(map nil
#'(lambda (function)
;; There are byte codes for the two-argument versions of these
Repository URL: https://bitbucket.org/xemacs/xemacs/
--
This is a commit notification from bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Use skip_ascii() in no_conversion_convert() when encoding.
10 years, 10 months
Aidan Kehoe
Aidan Kehoe
Another change to improve things for VM users a little. Frustratingly, it
doesn’t improve things that much in my use, though specifically when
profiling Fwrite_region_internal with a large file there’s a substantial,
measurable improvement.
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1387476791 0
# Node ID 7a538e1a4676a2229b4f1806dfa26725226f0ba7
# Parent 94a6b8fbd56e98dd8d90de2b793cea1c5fd21353
Use skip_ascii() in no_conversion_convert() when encoding.
src/ChangeLog addition:
2013-12-19 Aidan Kehoe <kehoea(a)parhasard.net>
* text.c:
* text.h:
* text.h (skip_ascii):
Move skip_ascii (), the very fast inline function from the
bytecount-to-charcount code, to text.h, to allow the coding
systems to use it too as needed.
* file-coding.c (no_conversion_convert):
Use skip_ascii() as appropriate here, halving the time taken to
write large files in my tests (again, relevant to VM buffers, but
not a panacea to our issues with them.)
diff -r 94a6b8fbd56e -r 7a538e1a4676 src/ChangeLog
--- a/src/ChangeLog Tue Dec 17 20:49:52 2013 +0200
+++ b/src/ChangeLog Thu Dec 19 18:13:11 2013 +0000
＠＠ -1,3 +1,16 ＠＠
+2013-12-19 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * text.c:
+ * text.h:
+ * text.h (skip_ascii):
+ Move skip_ascii (), the very fast inline function from the
+ bytecount-to-charcount code, to text.h, to allow the coding
+ systems to use it too as needed.
+ * file-coding.c (no_conversion_convert):
+ Use skip_ascii() as appropriate here, halving the time taken to
+ write large files in my tests (again, relevant to VM buffers, but
+ not a panacea to our issues with them.)
+
2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net>
* lisp.h:
diff -r 94a6b8fbd56e -r 7a538e1a4676 src/file-coding.c
--- a/src/file-coding.c Tue Dec 17 20:49:52 2013 +0200
+++ b/src/file-coding.c Thu Dec 19 18:13:11 2013 +0000
＠＠ -2851,18 +2851,29 ＠＠
}
else
{
-
- while (n--)
+ const Ibyte *bend = (const Ibyte *)src + n;
+
+ while (n > 0)
{
- c = *src++;
- if (byte_ascii_p (c))
+ if (byte_ascii_p (*src))
{
- assert (ch == 0);
- Dynarr_add (dst, c);
+ const Ibyte *nonascii = skip_ascii ((Ibyte *)src, bend);
+
+ Dynarr_add_many (dst, src, nonascii - src);
+ n -= nonascii - src;
+
+ src = nonascii;
+ if (n < 1)
+ {
+ break;
+ }
}
+
+ n--, c = *src++;
+
#ifdef MULE
- else if (ibyte_leading_byte_p (c))
- {
+ if (ibyte_leading_byte_p (c))
+ {
assert (ch == 0);
if (c == LEADING_BYTE_LATIN_ISO8859_1 ||
c == LEADING_BYTE_CONTROL_1)
diff -r 94a6b8fbd56e -r 7a538e1a4676 src/text.c
--- a/src/text.c Tue Dec 17 20:49:52 2013 +0200
+++ b/src/text.c Thu Dec 19 18:13:11 2013 +0000
＠＠ -2204,79 +2204,6 ＠＠
#ifdef MULE
-#ifdef EFFICIENT_INT_128_BIT
-# define STRIDE_TYPE INT_128_BIT
-# define HIGH_BIT_MASK \
- MAKE_128_BIT_UNSIGNED_CONSTANT (0x80808080808080808080808080808080)
-#elif defined (EFFICIENT_INT_64_BIT)
-# define STRIDE_TYPE INT_64_BIT
-# define HIGH_BIT_MASK MAKE_64_BIT_UNSIGNED_CONSTANT (0x8080808080808080)
-#else
-# define STRIDE_TYPE INT_32_BIT
-# define HIGH_BIT_MASK MAKE_32_BIT_UNSIGNED_CONSTANT (0x80808080)
-#endif
-
-#define ALIGN_BITS ((EMACS_UINT) (ALIGNOF (STRIDE_TYPE) - 1))
-#define ALIGN_MASK (~ ALIGN_BITS)
-#define ALIGNED(ptr) ((((EMACS_UINT) ptr) & ALIGN_BITS) == 0)
-#define STRIDE sizeof (STRIDE_TYPE)
-
-/* Skip as many ASCII bytes as possible in the memory block [PTR, END).
- Return pointer to the first non-ASCII byte. optimized for long
- stretches of ASCII. */
-inline static const Ibyte *
-skip_ascii (const Ibyte *ptr, const Ibyte *end)
-{
- const unsigned STRIDE_TYPE *ascii_end;
-
- /* Need to do in 3 sections -- before alignment start, aligned chunk,
- after alignment end. */
- while (!ALIGNED (ptr))
- {
- if (ptr == end || !byte_ascii_p (*ptr))
- return ptr;
- ptr++;
- }
- ascii_end = (const unsigned STRIDE_TYPE *) ptr;
- /* This loop screams, because we can detect ASCII
- characters 4 or 8 at a time. */
- while ((const Ibyte *) ascii_end + STRIDE <= end
- && !(*ascii_end & HIGH_BIT_MASK))
- ascii_end++;
- ptr = (Ibyte *) ascii_end;
- while (ptr < end && byte_ascii_p (*ptr))
- ptr++;
- return ptr;
-}
-
-/* Skip as many ASCII bytes as possible in the memory block [END, PTR),
- going downwards. Return pointer to the location above the first
- non-ASCII byte. Optimized for long stretches of ASCII. */
-inline static const Ibyte *
-skip_ascii_down (const Ibyte *ptr, const Ibyte *end)
-{
- const unsigned STRIDE_TYPE *ascii_end;
-
- /* Need to do in 3 sections -- before alignment start, aligned chunk,
- after alignment end. */
- while (!ALIGNED (ptr))
- {
- if (ptr == end || !byte_ascii_p (*(ptr - 1)))
- return ptr;
- ptr--;
- }
- ascii_end = (const unsigned STRIDE_TYPE *) ptr - 1;
- /* This loop screams, because we can detect ASCII
- characters 4 or 8 at a time. */
- while ((const Ibyte *) ascii_end >= end
- && !(*ascii_end & HIGH_BIT_MASK))
- ascii_end--;
- ptr = (Ibyte *) (ascii_end + 1);
- while (ptr > end && byte_ascii_p (*(ptr - 1)))
- ptr--;
- return ptr;
-}
-
/* Function equivalents of bytecount_to_charcount/charcount_to_bytecount.
These work on strings of all sizes but are more efficient than a simple
loop on large strings and probably less efficient on sufficiently small
diff -r 94a6b8fbd56e -r 7a538e1a4676 src/text.h
--- a/src/text.h Tue Dec 17 20:49:52 2013 +0200
+++ b/src/text.h Thu Dec 19 18:13:11 2013 +0000
＠＠ -831,12 +831,91 ＠＠
}
}
+#ifdef EFFICIENT_INT_128_BIT
+# define STRIDE_TYPE INT_128_BIT
+# define HIGH_BIT_MASK \
+ MAKE_128_BIT_UNSIGNED_CONSTANT (0x80808080808080808080808080808080)
+#elif defined (EFFICIENT_INT_64_BIT)
+# define STRIDE_TYPE INT_64_BIT
+# define HIGH_BIT_MASK MAKE_64_BIT_UNSIGNED_CONSTANT (0x8080808080808080)
+#else
+# define STRIDE_TYPE INT_32_BIT
+# define HIGH_BIT_MASK MAKE_32_BIT_UNSIGNED_CONSTANT (0x80808080)
+#endif
+
+#define ALIGN_BITS ((EMACS_UINT) (ALIGNOF (STRIDE_TYPE) - 1))
+#define ALIGN_MASK (~ ALIGN_BITS)
+#define ALIGNED(ptr) ((((EMACS_UINT) ptr) & ALIGN_BITS) == 0)
+#define STRIDE sizeof (STRIDE_TYPE)
+
+/* Skip as many ASCII bytes as possible in the memory block [PTR, END).
+ Return pointer to the first non-ASCII byte. optimized for long
+ stretches of ASCII. */
+DECLARE_INLINE_HEADER (
+const Ibyte *
+skip_ascii (const Ibyte *ptr, const Ibyte *end)
+)
+{
+ const unsigned STRIDE_TYPE *ascii_end;
+
+ /* Need to do in 3 sections -- before alignment start, aligned chunk,
+ after alignment end. */
+ while (!ALIGNED (ptr))
+ {
+ if (ptr == end || !byte_ascii_p (*ptr))
+ return ptr;
+ ptr++;
+ }
+ ascii_end = (const unsigned STRIDE_TYPE *) ptr;
+ /* This loop screams, because we can detect ASCII
+ characters 4 or 8 at a time. */
+ while ((const Ibyte *) ascii_end + STRIDE <= end
+ && !(*ascii_end & HIGH_BIT_MASK))
+ ascii_end++;
+ ptr = (Ibyte *) ascii_end;
+ while (ptr < end && byte_ascii_p (*ptr))
+ ptr++;
+ return ptr;
+}
+
+/* Skip as many ASCII bytes as possible in the memory block [END, PTR),
+ going downwards. Return pointer to the location above the first
+ non-ASCII byte. Optimized for long stretches of ASCII. */
+DECLARE_INLINE_HEADER (
+const Ibyte *
+skip_ascii_down (const Ibyte *ptr, const Ibyte *end)
+)
+{
+ const unsigned STRIDE_TYPE *ascii_end;
+
+ /* Need to do in 3 sections -- before alignment start, aligned chunk,
+ after alignment end. */
+ while (!ALIGNED (ptr))
+ {
+ if (ptr == end || !byte_ascii_p (*(ptr - 1)))
+ return ptr;
+ ptr--;
+ }
+ ascii_end = (const unsigned STRIDE_TYPE *) ptr - 1;
+ /* This loop screams, because we can detect ASCII
+ characters 4 or 8 at a time. */
+ while ((const Ibyte *) ascii_end >= end
+ && !(*ascii_end & HIGH_BIT_MASK))
+ ascii_end--;
+ ptr = (Ibyte *) (ascii_end + 1);
+ while (ptr > end && byte_ascii_p (*(ptr - 1)))
+ ptr--;
+ return ptr;
+}
+
#else
#define bytecount_to_charcount(ptr, len) ((Charcount) (len))
#define bytecount_to_charcount_fmt(ptr, len, fmt) ((Charcount) (len))
#define charcount_to_bytecount(ptr, len) ((Bytecount) (len))
#define charcount_to_bytecount_fmt(ptr, len, fmt) ((Bytecount) (len))
+#define skip_ascii(ptr, end) end
+#define skip_ascii_down(ptr, end) end
#endif /* MULE */
--
‘Liston operated so fast that he once accidentally amputated an assistant’s
fingers along with a patient’s leg, […] The patient and the assistant both
died of sepsis, and a spectator reportedly died of shock, resulting in the
only known procedure with a 300% mortality.’ (Atul Gawande, NEJM, 2012)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit/XEmacs: kehoea: Use skip_ascii() in no_conversion_convert() when encoding.
10 years, 10 months
Bitbucket
Bitbucket
1 new commit in XEmacs:
https://bitbucket.org/xemacs/xemacs/commits/7a538e1a4676/
Changeset: 7a538e1a4676
User: kehoea
Date: 2013-12-19 19:13:11
Summary: Use skip_ascii() in no_conversion_convert() when encoding.
src/ChangeLog addition:
2013-12-19 Aidan Kehoe <kehoea(a)parhasard.net>
* text.c:
* text.h:
* text.h (skip_ascii):
Move skip_ascii (), the very fast inline function from the
bytecount-to-charcount code, to text.h, to allow the coding
systems to use it too as needed.
* file-coding.c (no_conversion_convert):
Use skip_ascii() as appropriate here, halving the time taken to
write large files in my tests (again, relevant to VM buffers, but
not a panacea to our issues with them.)
Affected #: 4 files
diff -r 94a6b8fbd56e98dd8d90de2b793cea1c5fd21353 -r 7a538e1a4676a2229b4f1806dfa26725226f0ba7 src/ChangeLog
--- a/src/ChangeLog
+++ b/src/ChangeLog
＠＠ -1,3 +1,16 ＠＠
+2013-12-19 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * text.c:
+ * text.h:
+ * text.h (skip_ascii):
+ Move skip_ascii (), the very fast inline function from the
+ bytecount-to-charcount code, to text.h, to allow the coding
+ systems to use it too as needed.
+ * file-coding.c (no_conversion_convert):
+ Use skip_ascii() as appropriate here, halving the time taken to
+ write large files in my tests (again, relevant to VM buffers, but
+ not a panacea to our issues with them.)
+
2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net>
* lisp.h:
diff -r 94a6b8fbd56e98dd8d90de2b793cea1c5fd21353 -r 7a538e1a4676a2229b4f1806dfa26725226f0ba7 src/file-coding.c
--- a/src/file-coding.c
+++ b/src/file-coding.c
＠＠ -2851,18 +2851,29 ＠＠
}
else
{
-
- while (n--)
+ const Ibyte *bend = (const Ibyte *)src + n;
+
+ while (n > 0)
{
- c = *src++;
- if (byte_ascii_p (c))
+ if (byte_ascii_p (*src))
{
- assert (ch == 0);
- Dynarr_add (dst, c);
+ const Ibyte *nonascii = skip_ascii ((Ibyte *)src, bend);
+
+ Dynarr_add_many (dst, src, nonascii - src);
+ n -= nonascii - src;
+
+ src = nonascii;
+ if (n < 1)
+ {
+ break;
+ }
}
+
+ n--, c = *src++;
+
#ifdef MULE
- else if (ibyte_leading_byte_p (c))
- {
+ if (ibyte_leading_byte_p (c))
+ {
assert (ch == 0);
if (c == LEADING_BYTE_LATIN_ISO8859_1 ||
c == LEADING_BYTE_CONTROL_1)
diff -r 94a6b8fbd56e98dd8d90de2b793cea1c5fd21353 -r 7a538e1a4676a2229b4f1806dfa26725226f0ba7 src/text.c
--- a/src/text.c
+++ b/src/text.c
＠＠ -2204,79 +2204,6 ＠＠
#ifdef MULE
-#ifdef EFFICIENT_INT_128_BIT
-# define STRIDE_TYPE INT_128_BIT
-# define HIGH_BIT_MASK \
- MAKE_128_BIT_UNSIGNED_CONSTANT (0x80808080808080808080808080808080)
-#elif defined (EFFICIENT_INT_64_BIT)
-# define STRIDE_TYPE INT_64_BIT
-# define HIGH_BIT_MASK MAKE_64_BIT_UNSIGNED_CONSTANT (0x8080808080808080)
-#else
-# define STRIDE_TYPE INT_32_BIT
-# define HIGH_BIT_MASK MAKE_32_BIT_UNSIGNED_CONSTANT (0x80808080)
-#endif
-
-#define ALIGN_BITS ((EMACS_UINT) (ALIGNOF (STRIDE_TYPE) - 1))
-#define ALIGN_MASK (~ ALIGN_BITS)
-#define ALIGNED(ptr) ((((EMACS_UINT) ptr) & ALIGN_BITS) == 0)
-#define STRIDE sizeof (STRIDE_TYPE)
-
-/* Skip as many ASCII bytes as possible in the memory block [PTR, END).
- Return pointer to the first non-ASCII byte. optimized for long
- stretches of ASCII. */
-inline static const Ibyte *
-skip_ascii (const Ibyte *ptr, const Ibyte *end)
-{
- const unsigned STRIDE_TYPE *ascii_end;
-
- /* Need to do in 3 sections -- before alignment start, aligned chunk,
- after alignment end. */
- while (!ALIGNED (ptr))
- {
- if (ptr == end || !byte_ascii_p (*ptr))
- return ptr;
- ptr++;
- }
- ascii_end = (const unsigned STRIDE_TYPE *) ptr;
- /* This loop screams, because we can detect ASCII
- characters 4 or 8 at a time. */
- while ((const Ibyte *) ascii_end + STRIDE <= end
- && !(*ascii_end & HIGH_BIT_MASK))
- ascii_end++;
- ptr = (Ibyte *) ascii_end;
- while (ptr < end && byte_ascii_p (*ptr))
- ptr++;
- return ptr;
-}
-
-/* Skip as many ASCII bytes as possible in the memory block [END, PTR),
- going downwards. Return pointer to the location above the first
- non-ASCII byte. Optimized for long stretches of ASCII. */
-inline static const Ibyte *
-skip_ascii_down (const Ibyte *ptr, const Ibyte *end)
-{
- const unsigned STRIDE_TYPE *ascii_end;
-
- /* Need to do in 3 sections -- before alignment start, aligned chunk,
- after alignment end. */
- while (!ALIGNED (ptr))
- {
- if (ptr == end || !byte_ascii_p (*(ptr - 1)))
- return ptr;
- ptr--;
- }
- ascii_end = (const unsigned STRIDE_TYPE *) ptr - 1;
- /* This loop screams, because we can detect ASCII
- characters 4 or 8 at a time. */
- while ((const Ibyte *) ascii_end >= end
- && !(*ascii_end & HIGH_BIT_MASK))
- ascii_end--;
- ptr = (Ibyte *) (ascii_end + 1);
- while (ptr > end && byte_ascii_p (*(ptr - 1)))
- ptr--;
- return ptr;
-}
-
/* Function equivalents of bytecount_to_charcount/charcount_to_bytecount.
These work on strings of all sizes but are more efficient than a simple
loop on large strings and probably less efficient on sufficiently small
diff -r 94a6b8fbd56e98dd8d90de2b793cea1c5fd21353 -r 7a538e1a4676a2229b4f1806dfa26725226f0ba7 src/text.h
--- a/src/text.h
+++ b/src/text.h
＠＠ -831,12 +831,91 ＠＠
}
}
+#ifdef EFFICIENT_INT_128_BIT
+# define STRIDE_TYPE INT_128_BIT
+# define HIGH_BIT_MASK \
+ MAKE_128_BIT_UNSIGNED_CONSTANT (0x80808080808080808080808080808080)
+#elif defined (EFFICIENT_INT_64_BIT)
+# define STRIDE_TYPE INT_64_BIT
+# define HIGH_BIT_MASK MAKE_64_BIT_UNSIGNED_CONSTANT (0x8080808080808080)
+#else
+# define STRIDE_TYPE INT_32_BIT
+# define HIGH_BIT_MASK MAKE_32_BIT_UNSIGNED_CONSTANT (0x80808080)
+#endif
+
+#define ALIGN_BITS ((EMACS_UINT) (ALIGNOF (STRIDE_TYPE) - 1))
+#define ALIGN_MASK (~ ALIGN_BITS)
+#define ALIGNED(ptr) ((((EMACS_UINT) ptr) & ALIGN_BITS) == 0)
+#define STRIDE sizeof (STRIDE_TYPE)
+
+/* Skip as many ASCII bytes as possible in the memory block [PTR, END).
+ Return pointer to the first non-ASCII byte. optimized for long
+ stretches of ASCII. */
+DECLARE_INLINE_HEADER (
+const Ibyte *
+skip_ascii (const Ibyte *ptr, const Ibyte *end)
+)
+{
+ const unsigned STRIDE_TYPE *ascii_end;
+
+ /* Need to do in 3 sections -- before alignment start, aligned chunk,
+ after alignment end. */
+ while (!ALIGNED (ptr))
+ {
+ if (ptr == end || !byte_ascii_p (*ptr))
+ return ptr;
+ ptr++;
+ }
+ ascii_end = (const unsigned STRIDE_TYPE *) ptr;
+ /* This loop screams, because we can detect ASCII
+ characters 4 or 8 at a time. */
+ while ((const Ibyte *) ascii_end + STRIDE <= end
+ && !(*ascii_end & HIGH_BIT_MASK))
+ ascii_end++;
+ ptr = (Ibyte *) ascii_end;
+ while (ptr < end && byte_ascii_p (*ptr))
+ ptr++;
+ return ptr;
+}
+
+/* Skip as many ASCII bytes as possible in the memory block [END, PTR),
+ going downwards. Return pointer to the location above the first
+ non-ASCII byte. Optimized for long stretches of ASCII. */
+DECLARE_INLINE_HEADER (
+const Ibyte *
+skip_ascii_down (const Ibyte *ptr, const Ibyte *end)
+)
+{
+ const unsigned STRIDE_TYPE *ascii_end;
+
+ /* Need to do in 3 sections -- before alignment start, aligned chunk,
+ after alignment end. */
+ while (!ALIGNED (ptr))
+ {
+ if (ptr == end || !byte_ascii_p (*(ptr - 1)))
+ return ptr;
+ ptr--;
+ }
+ ascii_end = (const unsigned STRIDE_TYPE *) ptr - 1;
+ /* This loop screams, because we can detect ASCII
+ characters 4 or 8 at a time. */
+ while ((const Ibyte *) ascii_end >= end
+ && !(*ascii_end & HIGH_BIT_MASK))
+ ascii_end--;
+ ptr = (Ibyte *) (ascii_end + 1);
+ while (ptr > end && byte_ascii_p (*(ptr - 1)))
+ ptr--;
+ return ptr;
+}
+
#else
#define bytecount_to_charcount(ptr, len) ((Charcount) (len))
#define bytecount_to_charcount_fmt(ptr, len, fmt) ((Charcount) (len))
#define charcount_to_bytecount(ptr, len) ((Bytecount) (len))
#define charcount_to_bytecount_fmt(ptr, len, fmt) ((Bytecount) (len))
+#define skip_ascii(ptr, end) end
+#define skip_ascii_down(ptr, end) end
#endif /* MULE */
Repository URL: https://bitbucket.org/xemacs/xemacs/
--
This is a commit notification from bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
Re: [XEMACS COMMIT] Be lazy converting markers to integers, bytecode_{arithcompare, arithop}().
10 years, 10 months
Aidan Kehoe
Aidan Kehoe
Ar an séú lá déag de mí na Nollaig, scríobh Stephen J. Turnbull:
> Aidan Kehoe writes:
>
> > I would like to move to returning markers in #'max, #'min when all
> > arguments are markers that point to the same buffer,
>
> Are there efficiency implications to this?
Well, #'min and #'max will no longer be O(N) when all their arguments are
markers in the same buffer. (They will remain O(N * M) if any of the
arguments are *not* markers in the same buffer, where M is the number of
those markers.)
The reason this bit us with VM is that Kyle knew XEmacs well and wrote his
code to its strengths. And when Mule came along and changed an O(1)
operation to an O(N) operation, Kyle was no longer working on vm, and we
(the XEmacs people) have been looking at what actually was slow for us and
speeding that up. But VM was at the end of that queue.
> What is the logic for returning markers (other than efficiency)?
My logic is (was) that calling code can probably handle them already, and
the performance implications of doing it are more in the direction of lesser
astonishment.
There are 238 calls to #'max or #'min in the packages that I cannot
programmatically rule out as returning a marker that will escape, out of 1.8
million lines of code.
> > See also the comments in the tests. It surprised me strongly that the
> > markers weren’t preserved with changes that should have kept the same
> > relative character count, but it’s a separate issue that needs separate
> > investigation.
>
> Yeah, that sucks. I would go farther than "surprising" and just say
> that's a bug. But fixing that efficiently is probably not easy.
I haven’t looked into it.
--
‘Liston operated so fast that he once accidentally amputated an assistant’s
fingers along with a patient’s leg, […] The patient and the assistant both
died of sepsis, and a spectator reportedly died of shock, resulting in the
only known procedure with a 300% mortality.’ (Atul Gawande, NEJM, 2012)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
Re: [XEMACS PATCH] Have coding systems do some bytecount->charcount work
10 years, 10 months
Aidan Kehoe
Aidan Kehoe
Ar an fichiú lá de mí na Nollaig, scríobh Stephen J. Turnbull:
> viewmail-info deleted to avoid spamming myself.
>
> Aidan Kehoe writes:
>
> > The coding systems in general know exactly where the character
> > boundaries are, though, and if they record it there’s no need for
> > the buffer insertion code to do that work. The below patch gives
> > noticeably snappier performance for me loading large files with
> > reasonable amounts of non-ASCII characters.
>
> Is it possible that this patch could be improved to help the insdel
> code properly deal with markers and extents at character boundaries
> during in-buffer conversions, rather than trashing them as it
> currently does? Of course markers not at character boundary in the
> decoding operation can't be accurately preserved, but some
> approximation should be good enough.
Markers and extents are always at character boundaries, they never point to
the middle of an Ichar’s Ibyte representation.
If you mean rather that they overlap the boundaries of the region to be
changed, preserving them when encoding or decoding needs to be handled
within insdel.c. It is within that file, especially within
buffer_delete_range(), that the decision to delete any extents and to adjust
any markers is made. There should be an analogous buffer_replace_range (). I
note that GNU have had a replace_range() since 1997, and while it wasn’t
obvious then that it was necessary, I think it is.
> > It is very very much not ready to commit, I post it to show the idea and
> > because I don’t anticipate I’ll get to finishing it this month.
>
> What still needs to be done?
As it is, it aborts if you turn on ERROR_CHECK_TEXT, character_tell() gives
the wrong answer if the stream is rewound, it’s not implemented for a lot of
coding systems where its implementation would be trivial
--
‘Liston operated so fast that he once accidentally amputated an assistant’s
fingers along with a patient’s leg, […] The patient and the assistant both
died of sepsis, and a spectator reportedly died of shock, resulting in the
only known procedure with a 300% mortality.’ (Atul Gawande, NEJM, 2012)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit/xemacs-packages: 3 new changesets
10 years, 10 months
Bitbucket
Bitbucket
3 new commits in xemacs-packages:
https://bitbucket.org/xemacs/xemacs-packages/commits/6d5ae0181ed7/
Changeset: 6d5ae0181ed7
User: Norbert Koch
Date: 2013-12-19 09:10:45
Summary: Update xemacs-base
Affected #: 1 file
diff -r d27e84cb24a878eb5168ce16f9d95e01a49b2dcc -r 6d5ae0181ed7d726d23dec35be764ea2d8a624de .hgsubstate
--- a/.hgsubstate
+++ b/.hgsubstate
＠＠ -123,7 +123,7 ＠＠
4eb09b852b72373e7ce9790cb9ebafc7e1b7598e xemacs-packages/vm
d1d1893d29ed5c97fab849e1ffb3a51d778d8026 xemacs-packages/w3
fd7cd3bdb22b444b112299facd2375daa2091dee xemacs-packages/x-symbol
-c3b20c005d74dffd77a3fbe1ea025a630610be55 xemacs-packages/xemacs-base
+db82ab2d46e07fcadc37e5445deeec5323c25a07 xemacs-packages/xemacs-base
9c8d90ff018391ccc55abcf6967ea6a00e749f53 xemacs-packages/xemacs-devel
be5592eaca6a65548d138ecd753f2e71b123793a xemacs-packages/xetla
bc5e241f2ddfed169b3e679b85a030237d5132ee xemacs-packages/xlib
https://bitbucket.org/xemacs/xemacs-packages/commits/b86dd7757edc/
Changeset: b86dd7757edc
User: Norbert Koch
Date: 2013-12-19 09:11:05
Summary: XEmacs Package Release
Affected #: 1 file
diff -r 6d5ae0181ed7d726d23dec35be764ea2d8a624de -r b86dd7757edc92d695ef38c56207fec31861db74 ChangeLog
--- a/ChangeLog
+++ b/ChangeLog
＠＠ -1,3 +1,7 ＠＠
+2013-12-19 Norbert Koch <viteno(a)xemacs.org>
+
+ * Packages released: xemacs-base.
+
2013-12-12 Norbert Koch <viteno(a)xemacs.org>
* Packages released: xemacs-base.
https://bitbucket.org/xemacs/xemacs-packages/commits/b13d71d77a81/
Changeset: b13d71d77a81
User: Norbert Koch
Date: 2013-12-19 10:08:02
Summary: Pre-release xemacs-base
Affected #: 1 file
diff -r b86dd7757edc92d695ef38c56207fec31861db74 -r b13d71d77a816f8dde41af11bb8aee2b23bd81f9 .hgsubstate
--- a/.hgsubstate
+++ b/.hgsubstate
＠＠ -123,7 +123,7 ＠＠
4eb09b852b72373e7ce9790cb9ebafc7e1b7598e xemacs-packages/vm
d1d1893d29ed5c97fab849e1ffb3a51d778d8026 xemacs-packages/w3
fd7cd3bdb22b444b112299facd2375daa2091dee xemacs-packages/x-symbol
-db82ab2d46e07fcadc37e5445deeec5323c25a07 xemacs-packages/xemacs-base
+7834d0230e5895d137a4ade334c256f143b7704e xemacs-packages/xemacs-base
9c8d90ff018391ccc55abcf6967ea6a00e749f53 xemacs-packages/xemacs-devel
be5592eaca6a65548d138ecd753f2e71b123793a xemacs-packages/xetla
bc5e241f2ddfed169b3e679b85a030237d5132ee xemacs-packages/xlib
Repository URL: https://bitbucket.org/xemacs/xemacs-packages/
--
This is a commit notification from bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit/xemacs-base: 2 new changesets
10 years, 10 months
Bitbucket
Bitbucket
2 new commits in xemacs-base:
https://bitbucket.org/xemacs/xemacs-base/commits/40d4e5628536/
Changeset: 40d4e5628536
User: Norbert Koch
Date: 2013-12-19 09:11:05
Summary: XEmacs Package Release 2.39
Affected #: 2 files
diff -r db82ab2d46e07fcadc37e5445deeec5323c25a07 -r 40d4e56285368e857d386ce00946b18607f596bb ChangeLog
--- a/ChangeLog
+++ b/ChangeLog
＠＠ -1,3 +1,7 ＠＠
+2013-12-19 Norbert Koch <viteno(a)xemacs.org>
+
+ * Makefile (VERSION): XEmacs package 2.39 released.
+
2013-12-12 Michael Sperber <mike(a)xemacs.org>
* compile.el (compilation-error-regexp-alist-alist): Make it autoloaded.
diff -r db82ab2d46e07fcadc37e5445deeec5323c25a07 -r 40d4e56285368e857d386ce00946b18607f596bb Makefile
--- a/Makefile
+++ b/Makefile
＠＠ -17,7 +17,7 ＠＠
# the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
-VERSION = 2.38
+VERSION = 2.39
AUTHOR_VERSION =
MAINTAINER = XEmacs Development Team <xemacs-beta(a)xemacs.org>
PACKAGE = xemacs-base
https://bitbucket.org/xemacs/xemacs-base/commits/7834d0230e58/
Changeset: 7834d0230e58
User: Norbert Koch
Date: 2013-12-19 09:11:05
Summary: Added tag xemacs-base-2_39 for changeset 40d4e5628536
Affected #: 1 file
diff -r 40d4e56285368e857d386ce00946b18607f596bb -r 7834d0230e5895d137a4ade334c256f143b7704e .hgtags
--- a/.hgtags
+++ b/.hgtags
＠＠ -158,3 +158,4 ＠＠
678d942c7cb55aea3ebec285e7f99f89fdb0e80a xemacs-base-2_36
63697e754ff259d4a27d95aa8ac1fef4eec31629 xemacs-base-2_37
bb25c1e58cfb9283e824d65d0df9b720a2351c8c xemacs-base-2_38
+40d4e56285368e857d386ce00946b18607f596bb xemacs-base-2_39
Repository URL: https://bitbucket.org/xemacs/xemacs-base/
--
This is a commit notification from bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
10 years, 10 months
Aidan Kehoe
Aidan Kehoe
It struck me as odd that there was no way to implement something analagous
to the Common Lisp Cookbook #'replace-all in XEmacs, because there was
nothing (apart from #'write-char) which could write a subsequence of a
string to a buffer (or whatever) without consing. This fills that lacuna.
The most-used function in Common Lisp of the three this introduces is
probably #'write-string.
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1387301350 -7200
# Node ID cd4f5f1f1f4c20036b18e7b7ab56c919614b9bea
# Parent 72a9467f93fc5510ba331627ca9581719053c51c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
src/ChangeLog addition:
2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net>
* lisp.h:
* lisp.h (PARSE_KEYWORDS_8):
Correct this in cases where we can have noticeably fewer arguments
than KEYWORDS_OFFSET, check whether nargs > pk_offset.
Declare check_sequence_range in this header.
* print.c:
* print.c (Fwrite_sequence) New:
Write a sequence to a stream, in the same way #'write-char and
#'terpri do. API from Common Lisp, not GNU, so while there is some
char-int confoundance, it's more limited than usual with GNU APIs.
* print.c (syms_of_print):
Make it available.
* sequence.c (check_sequence_range):
Export this to other files.
lisp/ChangeLog addition:
2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-extra.el:
* cl-extra.el (write-string): New.
* cl-extra.el (write-line): New.
Add these here, implemented in terms of #'write-sequence in print.c.
tests/ChangeLog addition:
2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
Up max-lisp-eval-depth when compiling this file, some of what
we're doing in testing #'write-sequence is demanding.
* automated/lisp-tests.el (make-circular-list):
New argument VALUE, the car of the conses to create.
* automated/lisp-tests.el:
Test #'write-sequence, #'write-string, #'write-line with function,
buffer and marker STREAMs; test argument types, keyword argument
ranges and values.
diff -r 72a9467f93fc -r cd4f5f1f1f4c lisp/ChangeLog
--- a/lisp/ChangeLog Sun Dec 15 17:01:58 2013 +0000
+++ b/lisp/ChangeLog Tue Dec 17 19:29:10 2013 +0200
＠＠ -1,3 +1,10 ＠＠
+2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-extra.el:
+ * cl-extra.el (write-string): New.
+ * cl-extra.el (write-line): New.
+ Add these here, implemented in terms of #'write-sequence in print.c.
+
2013-09-15 Mats Lidell <matsl(a)cxemacs.org>
* files.el (mode-require-final-newline): Variable synced from
diff -r 72a9467f93fc -r cd4f5f1f1f4c lisp/cl-extra.el
--- a/lisp/cl-extra.el Sun Dec 15 17:01:58 2013 +0000
+++ b/lisp/cl-extra.el Tue Dec 17 19:29:10 2013 +0200
＠＠ -618,6 +618,38 ＠＠
;; files to do the same, multiple times.
(eval-when-compile (or (cl-compiling-file) (load "cl-macs")))
+;; XEmacs, functions from Common Lisp.
+(defun* write-string (string &optional output-stream &key (start 0) end)
+ "Output STRING to stream OUTPUT-STREAM.
+
+OUTPUT-STREAM defaults to the value of `standard-output', which see.
+
+Keywords:start and :end, if given, specify indices of a subsequence
+of STRING to output. They default to 0 and nil, meaning write the
+entire string.
+
+Returns STRING (not the subsequence of STRING that has been written to
+OUTPUT-STREAM)."
+ (check-type string string)
+ (write-sequence string output-stream :start start :end end))
+
+(defun* write-line (string &optional output-stream &key (start 0) end)
+ "Output STRING, followed by a newline, to OUTPUT-STREAM.
+
+STRING must be a string. OUTPUT-STREAM defaults to the value of
+`standard-output' (which see).
+
+Keywords:start and :end, if given, specify indices of a subsequence
+of STRING to output. They default to 0 and nil, meaning write the
+entire string.
+
+Returns STRING (note, not the subsequence of STRING that has been written to
+OUTPUT-STREAM)."
+ (check-type string string)
+ (prog1
+ (write-sequence string output-stream :start start :end end)
+ (terpri output-stream)))
+
;; Implementation limits.
;; XEmacs; call cl-float-limits at dump time.
diff -r 72a9467f93fc -r cd4f5f1f1f4c src/ChangeLog
--- a/src/ChangeLog Sun Dec 15 17:01:58 2013 +0000
+++ b/src/ChangeLog Tue Dec 17 19:29:10 2013 +0200
＠＠ -1,3 +1,20 ＠＠
+2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * lisp.h:
+ * lisp.h (PARSE_KEYWORDS_8):
+ Correct this in cases where we can have noticeably fewer arguments
+ than KEYWORDS_OFFSET, check whether nargs > pk_offset.
+ Declare check_sequence_range in this header.
+ * print.c:
+ * print.c (Fwrite_sequence) New:
+ Write a sequence to a stream, in the same way #'write-char and
+ #'terpri do. API from Common Lisp, not GNU, so while there is some
+ char-int confoundance, it's more limited than usual with GNU APIs.
+ * print.c (syms_of_print):
+ Make it available.
+ * sequence.c (check_sequence_range):
+ Export this to other files.
+
2013-12-15 Aidan Kehoe <kehoea(a)parhasard.net>
* number.h:
diff -r 72a9467f93fc -r cd4f5f1f1f4c src/lisp.h
--- a/src/lisp.h Sun Dec 15 17:01:58 2013 +0000
+++ b/src/lisp.h Tue Dec 17 19:29:10 2013 +0200
＠＠ -3633,7 +3633,7 ＠＠
Elemcount pk_i = nargs - 1, pk_offset = keywords_offset; \
Boolint pk_allow_other_keys = allow_other_keys; \
\
- if ((nargs - pk_offset) & 1) \
+ if ((nargs - pk_offset) & 1 && (nargs > pk_offset)) \
{ \
if (!allow_other_keys \
&& !(pk_allow_other_keys \
＠＠ -5307,6 +5307,9 ＠＠
EXFUN (Fsubseq, 3);
EXFUN (Fvalid_plist_p, 1);
+extern void check_sequence_range (Lisp_Object, Lisp_Object, Lisp_Object,
+ Lisp_Object);
+
extern Boolint check_eq_nokey (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object);
extern Boolint check_lss_key_car (Lisp_Object, Lisp_Object, Lisp_Object,
diff -r 72a9467f93fc -r cd4f5f1f1f4c src/print.c
--- a/src/print.c Sun Dec 15 17:01:58 2013 +0000
+++ b/src/print.c Tue Dec 17 19:29:10 2013 +0200
＠＠ -143,6 +143,8 ＠＠
Lisp_Object Qdisplay_error;
Lisp_Object Qprint_message_label;
+Lisp_Object Qwrite_sequence;
+
/* Force immediate output of all printed data. Used for debugging. */
int print_unbuffered;
＠＠ -838,6 +840,180 ＠＠
return character;
}
+DEFUN ("write-sequence", Fwrite_sequence, 1, MANY, 0, /*
+Output string, list, vector or bit-vector SEQUENCE to STREAM.
+
+STREAM defaults to the value of `standard-output', which see.
+
+Keywords:start and :end, if given, specify indices of a subsequence
+of SEQUENCE to output. They default to 0 and nil, meaning write the
+entire sequence.
+
+Elements of SEQUENCE can be characters (all are accepted by this function,
+though they may be corrupted depending on the coding system associated with
+STREAM) or integers below #x100, which are treated as equivalent to the
+characters with the corresponding code. This function is from Common Lisp,
+rather GNU Emacs API, so GNU Emacs' character-integer equivalence doesn't
+hold.
+
+Returns SEQUENCE (not the subsequence of SEQUENCE that has been written to
+STREAM).
+
+arguments: (SEQUENCE &optional STREAM &key (START 0) END)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object sequence = args[0], stream = (nargs > 1) ? args[1] : Qnil;
+ Lisp_Object reloc = Qnil;
+ Charcount starting = 0, ending = 1 + MOST_POSITIVE_FIXNUM;
+ Ibyte *nonreloc = NULL, *all = NULL, *allptr = all;
+ Bytecount bstart = 0, blen = 0;
+ Elemcount ii = 0;
+
+ PARSE_KEYWORDS_8 (Qwrite_sequence, nargs, args, 2, (start, end),
+ (start = Qzero), 2, 0);
+
+ CHECK_SEQUENCE (sequence);
+ CHECK_NATNUM (start);
+
+ if (!NILP (end))
+ {
+ CHECK_NATNUM (end);
+ }
+
+ stream = canonicalize_printcharfun (stream);
+
+ if (BIGNUMP (start) || (BIGNUMP (end)))
+ {
+ /* None of the sequences will have bignum lengths. */
+ check_sequence_range (sequence, start, end, Flength (sequence));
+
+ RETURN_NOT_REACHED (sequence);
+ }
+
+ starting = XFIXNUM (start);
+ if (FIXNUMP (end))
+ {
+ ending = XFIXNUM (end);
+ }
+
+ if (STRINGP (sequence))
+ {
+ Ibyte *stringp = XSTRING_DATA (sequence);
+ Ibyte *strend = stringp + XSTRING_LENGTH (sequence);
+
+ reloc = sequence;
+
+ for (ii = 0; ii < starting && stringp < strend; ++ii)
+ {
+ INC_IBYTEPTR (stringp);
+ }
+
+ if (ii != starting)
+ {
+ /* Bad value for start. */
+ check_sequence_range (sequence, start, end,
+ Flength (sequence));
+ RETURN_NOT_REACHED (sequence);
+ }
+
+ bstart = stringp - XSTRING_DATA (sequence);
+
+ for (; ii < ending && stringp < strend; ++ii)
+ {
+ INC_IBYTEPTR (stringp);
+ }
+
+ if (ii != ending && ending != (1 + MOST_POSITIVE_FIXNUM))
+ {
+ /* Bad value for end. */
+ check_sequence_range (sequence, start, end,
+ Flength (sequence));
+ RETURN_NOT_REACHED (sequence);
+ }
+
+ blen = stringp - (XSTRING_DATA (sequence) + bstart);
+ }
+ else
+ {
+ Lisp_Object length = Flength (sequence);
+
+ check_sequence_range (sequence, start, end, length);
+ ending = NILP (end) ? XFIXNUM (length) : XFIXNUM (end);
+
+ if (VECTORP (sequence))
+ {
+ Lisp_Object *vdata = XVECTOR_DATA (sequence);
+ /* Worst case scenario; all characters, all the longest possible. More
+ likely: lots of small integers. */
+ nonreloc = allptr
+ = alloca_ibytes (((ending - starting)) * MAX_ICHAR_LEN);
+
+ for (ii = starting; ii < ending; ++ii)
+ {
+ if (!CHARP (vdata[ii]))
+ {
+ check_integer_range (vdata[ii], Qzero, make_fixnum (0xff));
+ }
+
+ allptr += set_itext_ichar (allptr,
+ XCHAR_OR_CHAR_INT (vdata[ii]));
+ }
+ }
+ else if (CONSP (sequence))
+ {
+ /* Worst case scenario; all characters, all the longest
+ possible. More likely: lots of small integers. */
+ nonreloc = allptr
+ = alloca_ibytes (((ending - starting)) * MAX_ICHAR_LEN);
+ ii = 0;
+ {
+ EXTERNAL_LIST_LOOP_2 (elt, sequence)
+ {
+ if (ii >= starting)
+ {
+ if (ii >= ending)
+ {
+ break;
+ }
+
+ if (!CHARP (elt))
+ {
+ check_integer_range (elt, Qzero, make_fixnum (0xff));
+ }
+ allptr += set_itext_ichar (allptr,
+ XCHAR_OR_CHAR_INT (elt));
+ }
+ ++ii;
+ }
+ }
+ }
+ else if (BIT_VECTORP (sequence))
+ {
+ Ibyte one [MAX_ICHAR_LEN];
+ Lisp_Bit_Vector *vv = XBIT_VECTOR (sequence);
+
+ nonreloc = allptr
+ = alloca_ibytes (((ending - starting) *
+ (set_itext_ichar (one, (Ichar)1))));
+ for (ii = starting; ii < ending; ++ii)
+ {
+ allptr += set_itext_ichar (allptr, bit_vector_bit (vv, ii));
+ }
+ }
+ else if (NILP (sequence))
+ {
+ nonreloc = allptr = alloca_ibytes (1);
+ }
+
+ bstart = 0;
+ blen = allptr - nonreloc;
+ }
+
+ output_string (stream, nonreloc, reloc, bstart, blen);
+ return sequence;
+}
+
void
temp_output_buffer_setup (Lisp_Object bufname)
{
＠＠ -2977,6 +3153,7 ＠＠
DEFSYMBOL (Qdisplay_error);
DEFSYMBOL (Qprint_message_label);
+ DEFSYMBOL (Qwrite_sequence);
DEFSUBR (Fprin1);
DEFSUBR (Fprin1_to_string);
＠＠ -2986,6 +3163,7 ＠＠
DEFSUBR (Fdisplay_error);
DEFSUBR (Fterpri);
DEFSUBR (Fwrite_char);
+ DEFSUBR (Fwrite_sequence);
DEFSUBR (Falternate_debugging_output);
DEFSUBR (Fset_device_clear_left_side);
DEFSUBR (Fdevice_left_side_clear_p);
diff -r 72a9467f93fc -r cd4f5f1f1f4c src/sequence.c
--- a/src/sequence.c Sun Dec 15 17:01:58 2013 +0000
+++ b/src/sequence.c Tue Dec 17 19:29:10 2013 +0200
＠＠ -44,7 +44,7 ＠＠
invalid_state_2 ("object modified while traversing it", func, object);
}
-static void
+void
check_sequence_range (Lisp_Object sequence, Lisp_Object start,
Lisp_Object end, Lisp_Object length)
{
diff -r 72a9467f93fc -r cd4f5f1f1f4c tests/ChangeLog
--- a/tests/ChangeLog Sun Dec 15 17:01:58 2013 +0000
+++ b/tests/ChangeLog Tue Dec 17 19:29:10 2013 +0200
＠＠ -1,3 +1,15 ＠＠
+2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el:
+ Up max-lisp-eval-depth when compiling this file, some of what
+ we're doing in testing #'write-sequence is demanding.
+ * automated/lisp-tests.el (make-circular-list):
+ New argument VALUE, the car of the conses to create.
+ * automated/lisp-tests.el:
+ Test #'write-sequence, #'write-string, #'write-line with function,
+ buffer and marker STREAMs; test argument types, keyword argument
+ ranges and values.
+
2013-12-15 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (character):
diff -r 72a9467f93fc -r cd4f5f1f1f4c tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Sun Dec 15 17:01:58 2013 +0000
+++ b/tests/automated/lisp-tests.el Tue Dec 17 19:29:10 2013 +0200
＠＠ -29,6 +29,9 ＠＠
;;; See test-harness.el for instructions on how to run these tests.
(eval-when-compile
+ ;; The labels below give trouble with a max-lisp-eval-depth of less than
+ ;; about 2000, work around that:
+ (setq max-lisp-eval-depth (max 2000 max-lisp-eval-depth))
(condition-case nil
(require 'test-harness)
(file-error
＠＠ -102,12 +105,16 ＠＠
(Assert (eq (elt my-bit-vector 2) 0))
)
-(defun make-circular-list (length)
- "Create evil emacs-crashing circular list of length LENGTH"
+(defun make-circular-list (length &optional value)
+ "Create evil emacs-crashing circular list of length LENGTH.
+
+Optional VALUE is the value to go into the cars. If nil, some non-nil value
+will be used to make debugging easier."
(let ((circular-list
(make-list
length
- 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike)))
+ (or value
+ 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike))))
(setcdr (last circular-list) circular-list)
circular-list))
＠＠ -2867,8 +2874,10 ＠＠
#'(lambda (object) (if (fixnump object) 1 0)) list))
(string (map 'string
#'(lambda (object) (or (and (fixnump object)
- (int-char object))
- (decode-char 'ucs #x20ac))) list))
+ (int-char object))
+ (decode-char 'ucs #x20ac)
+ ?\x20))
+ list))
(gensym (gensym)))
(Assert (null (find 'not-in-it list)))
(Assert (null (find 'not-in-it vector)))
＠＠ -3119,4 +3128,327 ＠＠
(map nil #'set-marker markers fixnums)
(Assert-arith-equivalences markers "with Euro sign restored"))))
+;;-----------------------------------------------------
+;; Test #'write-sequence and friends.
+;;-----------------------------------------------------
+
+(macrolet
+ ((Assert-write-results (function context &key short-string long-string
+ sequences-too output-stream
+ clear-output get-last-output)
+ "Check correct output in CONTEXT for `write-sequence' and friends."
+ (let* ((short-bit-vector (map 'bit-vector #'logand short-string
+ (make-circular-list 1 1)))
+ (long-bit-vector (map 'bit-vector #'logand long-string
+ (make-circular-list 1 1)))
+ (short-bit-vector-string
+ (map #'string #'int-char short-bit-vector))
+ (long-bit-vector-string
+ (map #'string #'int-char long-bit-vector)))
+ `(progn
+ (,clear-output ,output-stream)
+ (,function ,short-string ,output-stream)
+ (Assert (equal ,short-string
+ (,get-last-output ,output-stream
+ ,(length short-string)))
+ ,(format "checking %s with short string, %s"
+ function context))
+ ,＠(when sequences-too
+ `((,clear-output ,output-stream)
+ (,function ,(vconcat short-string) ,output-stream)
+ (Assert (equal ,short-string
+ (,get-last-output ,output-stream
+ ,(length short-string)))
+ ,(format "checking %s with short vector, %s"
+ function context))
+ (,clear-output ,output-stream)
+ (,function ',(append short-string nil) ,output-stream)
+ (Assert (equal ,short-string
+ (,get-last-output ,output-stream
+ ,(length short-string)))
+ ,(format "checking %s with short list, %s"
+ function context))
+ (,clear-output ,output-stream)
+ (,function ,short-bit-vector ,output-stream)
+ (Assert (equal ,short-bit-vector-string
+ (,get-last-output
+ ,output-stream
+ ,(length short-bit-vector-string)))
+ ,(format
+ "checking %s with short bit-vector, %s"
+ function context))
+ (,clear-output ,output-stream)
+ (,function ,long-bit-vector ,output-stream)
+ (Assert (equal ,long-bit-vector-string
+ (,get-last-output
+ ,output-stream
+ ,(length long-bit-vector-string)))
+ ,(format
+ "checking %s with long bit-vector, %s"
+ function context))))
+ ,(cons
+ 'progn
+ (loop
+ for (subseq-start subseq-end description)
+ in `((0 ,(length short-string) "trivial range")
+ (4 7 "harder range"))
+ nconc
+ `((,clear-output ,output-stream)
+ (,function ,short-string ,output-stream :start ,subseq-start
+:end ,subseq-end)
+ (Assert
+ (equal ,(subseq short-string subseq-start subseq-end)
+ (,get-last-output ,output-stream
+ ,(- subseq-end subseq-start)))
+ ,(format
+ "checking %s with short string, %s, %s"
+ function context description))
+ ,＠(when sequences-too
+ `((,clear-output ,output-stream)
+ (,function ,(vconcat short-string) ,output-stream
+:start ,subseq-start :end ,subseq-end)
+ (Assert
+ (equal ,(subseq short-string subseq-start subseq-end)
+ (,get-last-output ,output-stream
+ ,(- subseq-end subseq-start)))
+ ,(format
+ "checking %s with short vector, %s, %s"
+ function context description))
+ (,clear-output ,output-stream)
+ (,function ',(append short-string nil) ,output-stream
+:start ,subseq-start :end ,subseq-end)
+ (Assert
+ (equal ,(subseq short-string subseq-start subseq-end)
+ (,get-last-output
+ ,output-stream
+ ,(- subseq-end subseq-start )))
+ ,(format "checking %s with short list, %s, %s"
+ function context description))
+ (,clear-output ,output-stream)
+ (,function ,short-bit-vector ,output-stream
+:start ,subseq-start :end ,subseq-end)
+ (Assert
+ (equal ,(subseq short-bit-vector-string subseq-start
+ subseq-end)
+ (,get-last-output ,output-stream
+ ,(- subseq-end subseq-start)))
+ ,(format
+ "checking %s with short bit-vector, %s, %s"
+ function context description)))))))
+ ,(cons
+ 'progn
+ (loop
+ for (subseq-start subseq-end description)
+ in `((0 ,(length long-string) "trivial range")
+ (4 90 "harder range"))
+ nconc
+ `((,clear-output ,output-stream)
+ (,function ,long-string ,output-stream :start ,subseq-start
+:end ,subseq-end)
+ (Assert
+ (equal ,(subseq long-string subseq-start subseq-end)
+ (,get-last-output ,output-stream
+ ,(- subseq-end subseq-start)))
+ ,(format
+ "checking %s with long string, %s, %s"
+ function context description))
+ ,＠(when sequences-too
+ `((,clear-output ,output-stream)
+ (,function ,(vconcat long-string) ,output-stream
+:start ,subseq-start :end ,subseq-end)
+ (Assert
+ (equal ,(subseq long-string subseq-start subseq-end)
+ (,get-last-output
+ ,output-stream
+ ,(- subseq-end subseq-start)))
+ ,(format
+ "checking %s with long vector, %s, %s"
+ function context description))
+ (,clear-output ,output-stream)
+ (,function ',(append long-string nil) ,output-stream
+:start ,subseq-start :end ,subseq-end)
+ (Assert
+ (equal ,(subseq long-string subseq-start subseq-end)
+ (,get-last-output ,output-stream
+ ,(- subseq-end subseq-start)))
+ ,(format "checking %s with long list, %s, %s"
+ function context description))
+ (,clear-output ,output-stream)
+ (,function ,long-bit-vector ,output-stream
+:start ,subseq-start :end ,subseq-end)
+ (Assert
+ (equal ,(subseq long-bit-vector-string
+ subseq-start subseq-end)
+ (,get-last-output
+ ,output-stream
+ ,(- subseq-end subseq-start)))
+ ,(format
+ "checking %s with long bit-vector, %s, %s"
+ function context description)))))))
+ (,clear-output ,output-stream))))
+ (test-write-string (function &key sequences-too worry-about-newline)
+ (let* ((short-string "hello there")
+ (long-string
+ (decode-coding-string
+ (concat
+ "\xd8\xb3\xd9\x84\xd8\xa7\xd9\x85 \xd8\xb9\xd9\x84"
+ "\xdb\x8c\xda\xa9\xd9\x85\x2c \xd8\xa7\xd8\xb3\xd9"
+ "\x85 \xd9\x85\xd9\x86 \xd8\xa7\xdb\x8c\xd8\xaf\xd9"
+ "\x86 \xda\xa9\xdb\x8c\xd9\x88 \xd8\xa7\xd8\xb3\xd8"
+ "\xaa\x2e \xd9\x85\xd9\x86 \xd8\xa7\xdb\x8c\xd8\xb1"
+ "\xd9\x84\xd9\x86\xd8\xaf\xdb\x8c \xd8\xa7\xd9\x85"
+ "\x2c \xd9\x88 \xd9\x85\xd9\x86 \xd8\xaf\xd8\xb1 "
+ "\xd8\xa8\xdb\x8c\xd9\x85\xd8\xa7\xd8\xb1\xd8\xb3"
+ "\xd8\xaa\xd8\xa7\xd9\x86 \xda\xa9\xd8\xa7\xd8\xb1"
+ "\xd9\x85\xdb\x8c\xe2\x80\x8c\xda\xa9\xd9\x86\xd9"
+ "\x85\x2e")
+ (if (featurep 'mule) 'utf-8 'raw-text-unix)))
+ (long-string (concat long-string long-string long-string
+ long-string long-string long-string
+ long-string long-string long-string
+ long-string long-string long-string)))
+ `(with-temp-buffer
+ (let* ((long-string ,long-string)
+ (stashed-data
+ (get-buffer-create
+ (generate-new-buffer-name " *stash*")))
+ (function-output-stream
+ (apply-partially
+ #'(lambda (buffer character)
+ (insert-char character 1 nil buffer))
+ stashed-data))
+ (marker-buffer
+ (get-buffer-create
+ (generate-new-buffer-name " *for-marker*")))
+ (marker-base-position 40)
+ (marker
+ (progn
+ (insert-char ?\xff 90 nil marker-buffer)
+ (set-marker (make-marker) 40 marker-buffer))))
+ (unwind-protect
+ (labels
+ ((clear-buffer (buffer)
+ (delete-region (point-min buffer) (point-max buffer)
+ buffer))
+ (clear-stashed-data (ignore)
+ (delete-region (point-min stashed-data)
+ (point-max stashed-data)
+ stashed-data))
+ (clear-marker-data (marker)
+ (delete-region marker-base-position marker
+ (marker-buffer marker)))
+ (buffer-output (buffer length)
+ (and (> (point buffer) length)
+ (buffer-substring (- (point buffer) length)
+ (point buffer) buffer)))
+ (stashed-data-output (ignore length)
+ (and (> (point stashed-data) length)
+ (buffer-substring (- (point stashed-data)
+ length)
+ (point stashed-data)
+ stashed-data)))
+ (marker-data (marker length)
+ (and (> marker length)
+ (buffer-substring (- marker length) marker
+ (marker-buffer marker))))
+ (buffer-output-sans-newline (buffer length)
+ (and (> (point buffer) (+ length 1))
+ (buffer-substring (- (point buffer) length 1)
+ (1- (point buffer)))))
+ (stashed-data-output-sans-newline (ignore length)
+ (and (> (point stashed-data) (+ length 1))
+ (buffer-substring (- (point stashed-data)
+ length 1)
+ (1- (point stashed-data))
+ stashed-data)))
+ (marker-data-sans-newline (marker length)
+ (and (> marker (+ length 1))
+ (buffer-substring (- marker length 1)
+ (1- marker)
+ (marker-buffer marker)))))
+ (Check-Error wrong-number-of-arguments (,function))
+ (,(if (subrp (symbol-function function))
+ 'progn
+ 'Implementation-Incomplete-Expect-Failure)
+ (Check-Error wrong-number-of-arguments
+ (,function ,short-string
+ (current-buffer) :start))
+ (Check-Error wrong-number-of-arguments
+ (,function ,short-string
+ (current-buffer) :start 0
+ :end nil :start)))
+ (Check-Error invalid-keyword-argument
+ (,function ,short-string
+ (current-buffer)
+:test #'eq))
+ (Check-Error wrong-type-argument (,function pi))
+ ,＠(if sequences-too
+ `((Check-Error
+ args-out-of-range
+ (,function (vector most-positive-fixnum)))
+ (Check-Error
+ args-out-of-range
+ (,function (list most-positive-fixnum)))
+ ,＠(if (featurep 'mule)
+ `((Check-Error
+ args-out-of-range
+ (,function
+ (vector
+ (char-int
+ (decode-char 'ucs #x20ac))))))))
+ `((Check-Error wrong-type-argument
+ (,function
+ ',(append short-string nil)))
+ (Check-Error wrong-type-argument
+ (,function
+ ,(vconcat long-string)))
+ (Check-Error wrong-type-argument
+ (,function #*010010001010101))))
+ (Check-Error wrong-type-argument
+ (,function ,short-string (current-buffer)
+:start 0.0))
+ (Check-Error wrong-type-argument
+ (,function ,short-string (current-buffer)
+:end 4.0))
+ (Check-Error invalid-function
+ (,function ,short-string pi))
+ (Check-Error args-out-of-range
+ (,function ,short-string (current-buffer)
+:end ,(1+ (length short-string))))
+ (Check-Error args-out-of-range
+ (,function ,short-string nil
+:start
+ ,(1+ (length short-string))))
+ ;; Not checked here; output to a stdio stream, output
+ ;; to an lstream, output to a frame.
+ (Assert-write-results
+ ,function "buffer point" :short-string ,short-string
+:long-string ,long-string :sequences-too ,sequences-too
+:output-stream (current-buffer)
+:clear-output clear-buffer
+:get-last-output
+ ,(if worry-about-newline 'buffer-output-sans-newline
+ 'buffer-output))
+ (Assert-write-results
+ ,function "function output" :short-string ,short-string
+:long-string ,long-string :sequences-too ,sequences-too
+:output-stream function-output-stream
+:clear-output clear-stashed-data
+:get-last-output
+ ,(if worry-about-newline
+ 'stashed-data-output-sans-newline
+ 'stashed-data-output))
+ (Assert-write-results
+ ,function "marker output" :short-string ,short-string
+:long-string ,long-string :sequences-too ,sequences-too
+:output-stream marker :clear-output clear-marker-data
+:get-last-output ,(if worry-about-newline
+ 'marker-data-sans-newline
+ 'marker-data)))
+ (kill-buffer stashed-data)
+ (kill-buffer marker-buffer)))))))
+ (test-write-string write-sequence :sequences-too t)
+ (test-write-string write-string :sequences-too nil)
+ (test-write-string write-line :worry-about-newline t :sequences-too nil))
+
;;; end of lisp-tests.el
--
‘Liston operated so fast that he once accidentally amputated an assistant’s
fingers along with a patient’s leg, […] The patient and the assistant both
died of sepsis, and a spectator reportedly died of shock, resulting in the
only known procedure with a 300% mortality.’ (Atul Gawande, NEJM, 2012)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Use a face, show more context, #'blink-matching-open
10 years, 10 months
Aidan Kehoe
Aidan Kehoe
I’ve found that #'blink-matching-open tends not to show enough context when
the opening parenthesis has comma, ,＠, etc. before it, if you’re writing
vaguely complicate macros. (See much of my code in tests/automated/.)
This change fixes that; it also highlights the particular parenthesis using
the isearch face, which is useful when you have multiple open parentheses on
the same line, as is usual with #'labels, #'macrolet.
Normally #'message, #'lmessage cannot show face information, because they
call #'format, which strips this. I’ve changed them not to call it when
there are no ARGS. A more exhaustive solution to this is probably to change
#'format to preserve extent information by default.
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1387306192 -7200
# Node ID 94a6b8fbd56e98dd8d90de2b793cea1c5fd21353
# Parent cd4f5f1f1f4c20036b18e7b7ab56c919614b9bea
Use a face, show more context around open parenthesis, #'blink-matching-open
lisp/ChangeLog addition:
2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net>
* simple.el (blink-matching-open):
When showing the opening parenthesis in the minibiffer, use the
isearch face for it, in case there are multiple parentheses in the
text shown.
When writing moderately involved macros, it's often not enough
just to show the backquote context before the parenthesis
(e.g. ＠,.`). Skip over that when searching for useful context in
the same way we skip over space and tab.
* simple.el (message):
* simple.el (lmessage):
If there are no ARGS, don't call #'format. This allows extent
information to be passed through to the minibuffer.
It's probably better still to update #'format to preserve extent
info.
diff -r cd4f5f1f1f4c -r 94a6b8fbd56e lisp/ChangeLog
--- a/lisp/ChangeLog Tue Dec 17 19:29:10 2013 +0200
+++ b/lisp/ChangeLog Tue Dec 17 20:49:52 2013 +0200
＠＠ -1,3 +1,20 ＠＠
+2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * simple.el (blink-matching-open):
+ When showing the opening parenthesis in the minibiffer, use the
+ isearch face for it, in case there are multiple parentheses in the
+ text shown.
+ When writing moderately involved macros, it's often not enough
+ just to show the backquote context before the parenthesis
+ (e.g. ＠,.`). Skip over that when searching for useful context in
+ the same way we skip over space and tab.
+ * simple.el (message):
+ * simple.el (lmessage):
+ If there are no ARGS, don't call #'format. This allows extent
+ information to be passed through to the minibuffer.
+ It's probably better still to update #'format to preserve extent
+ info.
+
2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-extra.el:
diff -r cd4f5f1f1f4c -r 94a6b8fbd56e lisp/simple.el
--- a/lisp/simple.el Tue Dec 17 19:29:10 2013 +0200
+++ b/lisp/simple.el Tue Dec 17 20:49:52 2013 +0200
＠＠ -3304,9 +3304,10 ＠＠
(save-excursion
(save-restriction
(if blink-matching-paren-distance
- (narrow-to-region (max (point-min)
- (- (point) blink-matching-paren-distance))
- oldpos))
+ (narrow-to-region
+ (max (point-min)
+ (- (point) blink-matching-paren-distance))
+ oldpos))
(condition-case ()
(let ((parse-sexp-ignore-comments
(and parse-sexp-ignore-comments
＠＠ -3322,46 +3323,75 ＠＠
(matching-paren (char-after blinkpos))))))
(if mismatch (setq blinkpos nil))
(if blinkpos
- (progn
- (goto-char blinkpos)
- (if (pos-visible-in-window-p)
- (and blink-matching-paren-on-screen
- (progn
- (auto-show-make-point-visible)
- (sit-for blink-matching-delay)))
- (goto-char blinkpos)
- (lmessage 'command "Matches %s"
- ;; Show what precedes the open in its line, if anything.
- (if (save-excursion
- (skip-chars-backward " \t")
- (not (bolp)))
- (buffer-substring (progn (beginning-of-line) (point))
- (1+ blinkpos))
- ;; Show what follows the open in its line, if anything.
- (if (save-excursion
- (forward-char 1)
- (skip-chars-forward " \t")
- (not (eolp)))
- (buffer-substring blinkpos
- (progn (end-of-line) (point)))
- ;; Otherwise show the previous nonblank line,
- ;; if there is one.
- (if (save-excursion
- (skip-chars-backward "\n \t")
- (not (bobp)))
- (concat
- (buffer-substring (progn
- (skip-chars-backward "\n \t")
- (beginning-of-line)
- (point))
- (progn (end-of-line)
- (skip-chars-backward " \t")
- (point)))
- ;; Replace the newline and other whitespace with `...'.
- "..."
- (buffer-substring blinkpos (1+ blinkpos)))
- ;; There is nothing to show except the char itself.
- (buffer-substring blinkpos (1+ blinkpos))))))))
+ (labels
+ ((buffer-substring-highlight-blinkpos (start end)
+ ;; Sometimes there are sufficiently many
+ ;; parentheses on a line that it's *very*
+ ;; useful to see exactly which is the match.
+ (let* ((string (buffer-substring start end))
+ (extent (make-extent (- blinkpos start)
+ (1+ (- blinkpos start))
+ string)))
+ (set-extent-face extent 'isearch)
+ (set-extent-property extent 'duplicable t)
+ string))
+ (before-backquote-context ()
+ ;; Just showing the backquote context is often not
+ ;; informative enough, if you're writing vaguely
+ ;; complex macros. Move past it.
+ (skip-chars-backward "`,＠.")))
+ (declare (inline before-backquote-context))
+ (goto-char blinkpos)
+ (if (pos-visible-in-window-p)
+ (and blink-matching-paren-on-screen
+ (progn
+ (auto-show-make-point-visible)
+ (sit-for blink-matching-delay)))
+ (goto-char blinkpos)
+ (lmessage
+ 'command
+ (concat
+ "Matches "
+ ;; Show what precedes the open in its line, if
+ ;; anything.
+ (if (save-excursion
+ (before-backquote-context)
+ (skip-chars-backward " \t")
+ (not (bolp)))
+ (buffer-substring-highlight-blinkpos
+ (progn (beginning-of-line) (point))
+ (1+ blinkpos))
+ ;; Show what follows the open in its line, if
+ ;; anything.
+ (if (save-excursion
+ (forward-char 1)
+ (skip-chars-forward " \t")
+ (not (eolp)))
+ (buffer-substring-highlight-blinkpos
+ (progn (before-backquote-context) (point))
+ (progn (end-of-line (point))))
+ ;; Otherwise show the previous nonblank line,
+ ;; if there is one.
+ (if (save-excursion
+ (skip-chars-backward "\n \t")
+ (not (bobp)))
+ (concat
+ (buffer-substring
+ (progn (skip-chars-backward "\n \t")
+ (beginning-of-line)
+ (point))
+ (progn (end-of-line)
+ (skip-chars-backward " \t")
+ (point)))
+ ;; Replace the newline and other whitespace
+ ;; with `...'.
+ "..."
+ (buffer-substring-highlight-blinkpos
+ blinkpos (1+ blinkpos)))
+ ;; There is nothing to show except the char
+ ;; itself.
+ (buffer-substring-highlight-blinkpos
+ blinkpos (1+ blinkpos)))))))))
(cond (mismatch
(display-message 'no-log "Mismatched parentheses"))
((not blink-matching-paren-distance)
＠＠ -4501,9 +4531,9 ＠＠
(if (and (null fmt) (null args))
(prog1 nil
(clear-message nil))
- (let ((str (apply 'format fmt args)))
- (display-message 'message str)
- str)))
+ (let ((string (if args (apply 'format fmt args) fmt)))
+ (display-message 'message string)
+ string)))
(defun lmessage (label fmt &rest args)
"Print a one-line message at the bottom of the frame.
＠＠ -4514,10 +4544,9 ＠＠
(if (and (null fmt) (null args))
(prog1 nil
(clear-message label nil))
- (let ((str (apply 'format fmt args)))
- (display-message label str)
- str)))
-
+ (let ((string (if args (apply 'format fmt args) fmt)))
+ (display-message label string)
+ string)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; warning code ;;
--
‘Liston operated so fast that he once accidentally amputated an assistant’s
fingers along with a patient’s leg, […] The patient and the assistant both
died of sepsis, and a spectator reportedly died of shock, resulting in the
only known procedure with a 300% mortality.’ (Atul Gawande, NEJM, 2012)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments