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 <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.
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 <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 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 <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 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 <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 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.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches