Commits

Aidan Kehoe committed cd4f5f1

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.

Comments (0)

Files changed (8)

+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
 ;; 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.
+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:
       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                                  \
 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,
 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;
 
   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)
 {
 
   DEFSYMBOL (Qdisplay_error);
   DEFSYMBOL (Qprint_message_label);
+  DEFSYMBOL (Qwrite_sequence);
 
   DEFSUBR (Fprin1);
   DEFSUBR (Fprin1_to_string);
   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);
   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)
 {
+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):

tests/automated/lisp-tests.el

 ;;; 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
   (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))
 
 			#'(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)))
       (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