1 new commit in XEmacs:
https://bitbucket.org/xemacs/xemacs/commits/cd4f5f1f1f4c/
Changeset: cd4f5f1f1f4c
User: kehoea
Date: 2013-12-17 18:29:10
Summary: Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
src/ChangeLog addition:
2013-12-17 Aidan Kehoe <[email protected]>
* 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 <[email protected]>
* 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 <[email protected]>
* 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.
Affected #: 8 files
diff -r 72a9467f93fc5510ba331627ca9581719053c51c -r cd4f5f1f1f4c20036b18e7b7ab56c919614b9bea lisp/ChangeLog
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,10 @@
+2013-12-17 Aidan Kehoe <[email protected]>
+
+ * 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 <[email protected]>
* files.el (mode-require-final-newline): Variable synced from
diff -r 72a9467f93fc5510ba331627ca9581719053c51c -r cd4f5f1f1f4c20036b18e7b7ab56c919614b9bea lisp/cl-extra.el
--- a/lisp/cl-extra.el
+++ b/lisp/cl-extra.el
@@ -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 72a9467f93fc5510ba331627ca9581719053c51c -r cd4f5f1f1f4c20036b18e7b7ab56c919614b9bea src/ChangeLog
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,20 @@
+2013-12-17 Aidan Kehoe <[email protected]>
+
+ * 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 <[email protected]>
* number.h:
diff -r 72a9467f93fc5510ba331627ca9581719053c51c -r cd4f5f1f1f4c20036b18e7b7ab56c919614b9bea src/lisp.h
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -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 72a9467f93fc5510ba331627ca9581719053c51c -r cd4f5f1f1f4c20036b18e7b7ab56c919614b9bea src/print.c
--- a/src/print.c
+++ b/src/print.c
@@ -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 72a9467f93fc5510ba331627ca9581719053c51c -r cd4f5f1f1f4c20036b18e7b7ab56c919614b9bea src/sequence.c
--- a/src/sequence.c
+++ b/src/sequence.c
@@ -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 72a9467f93fc5510ba331627ca9581719053c51c -r cd4f5f1f1f4c20036b18e7b7ab56c919614b9bea tests/ChangeLog
--- a/tests/ChangeLog
+++ b/tests/ChangeLog
@@ -1,3 +1,15 @@
+2013-12-17 Aidan Kehoe <[email protected]>
+
+ * 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 <[email protected]>
* automated/lisp-tests.el (character):
diff -r 72a9467f93fc5510ba331627ca9581719053c51c -r cd4f5f1f1f4c20036b18e7b7ab56c919614b9bea tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el
+++ b/tests/automated/lisp-tests.el
@@ -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
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.
lmpx.com only provides a reader for public news (NNTP) servers. It is not
affiliated with the servers or forums shown here and is not responsible for
the content of articles, which is written by their respective authors.