Mercurial > hg > xemacs-beta
changeset 5772:cd4f5f1f1f4c
Add #'write-sequence, on the model of #'write-char, API from Common Lisp.
src/ChangeLog addition:
2013-12-17 Aidan Kehoe <kehoea@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@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@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.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Tue, 17 Dec 2013 19:29:10 +0200 |
| parents | 72a9467f93fc |
| children | 94a6b8fbd56e |
| files | lisp/ChangeLog lisp/cl-extra.el src/ChangeLog src/lisp.h src/print.c src/sequence.c tests/ChangeLog tests/automated/lisp-tests.el |
| diffstat | 8 files changed, 588 insertions(+), 7 deletions(-) [+] |
line wrap: on
line diff
--- 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@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@cxemacs.org> * files.el (mode-require-final-newline): Variable synced from
--- 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.
--- 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@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@parhasard.net> * number.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,
--- 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);
--- 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) {
--- 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@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@parhasard.net> * automated/lisp-tests.el (character):
--- 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