bug#18652: 25.0.50; [PATCH] Add fresh-line

[Leo Liu <sdl.web@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 2648 bytes --]

On 2014-10-08 09:54 +0800, Leo Liu wrote:
> How about something like this? Thanks, Leo.

This is the full patch (documentation, tests etc.) without the changelog
entries. Also improved to support print to stdout in noninteractive
mode. Comments?

Thanks, Leo

=== modified file 'doc/lispref/streams.texi'
--- doc/lispref/streams.texi	2014-03-18 01:19:03 +0000
+++ doc/lispref/streams.texi	2014-10-08 02:36:52 +0000
@@ -621,6 +621,13 @@
 for ``terminate print''.
 @end defun
 
+@defun fresh-line &optional stream
+@cindex fresh line in print
+This function outputs a newline to @var{stream} unless already at the
+beginning of a line. Return @code{t} if a newline is printed. Signal
+an error if @var{stream} is a function.
+@end defun
+
 @defun write-char character &optional stream
 This function outputs @var{character} to @var{stream}.  It returns
 @var{character}.

=== modified file 'src/print.c'
--- src/print.c	2014-09-11 06:21:55 +0000
+++ src/print.c	2014-10-08 04:58:12 +0000
@@ -58,6 +58,9 @@
 #define PRINT_CIRCLE 200
 static Lisp_Object being_printed[PRINT_CIRCLE];
 
+/* Last char printed to stdout by printchar.  */
+static unsigned int printchar_stdout_last;
+
 /* When printing into a buffer, first we put the text in this
    block, then insert it all at once.  */
 static char *print_buffer;
@@ -238,6 +241,7 @@
 	}
       else if (noninteractive)
 	{
+	  printchar_stdout_last = ch;
 	  fwrite (str, 1, len, stdout);
 	  noninteractive_need_newline = 1;
 	}
@@ -530,6 +534,32 @@
   return Qt;
 }
 
+DEFUN ("fresh-line", Ffresh_line, Sfresh_line, 0, 1, 0,
+       doc: /* Output a newline unless already at the beginning of a line.
+Value is non-nil if a newline is printed.
+Signal an error if PRINTCHARFUN is a function.  */)
+  (Lisp_Object printcharfun)
+{
+  Lisp_Object val = Qnil;
+
+  PRINTDECLARE;
+  if (NILP (printcharfun))
+    printcharfun = Vstandard_output;
+  PRINTPREPARE;
+
+  if (FUNCTIONP (printcharfun))
+    signal_error ("Unsupported function argument", printcharfun);
+
+  if (noninteractive && !NILP (printcharfun))
+    val = printchar_stdout_last == 10 ? Qnil : Qt;
+  else if (NILP (Fbolp ()))
+    val = Qt;
+
+  if (!NILP (val)) PRINTCHAR ('\n');
+  PRINTFINISH;
+  return val;
+}
+
 DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
        doc: /* Output the printed representation of OBJECT, any Lisp object.
 Quoting characters are printed when needed to make output that `read'
@@ -2334,6 +2364,7 @@
   defsubr (&Sprinc);
   defsubr (&Sprint);
   defsubr (&Sterpri);
+  defsubr (&Sfresh_line);
   defsubr (&Swrite_char);
 #ifdef WITH_REDIRECT_DEBUGGING_OUTPUT
   defsubr (&Sredirect_debugging_output);


[-- Attachment #2: print-tests.el --]
[-- Type: text/plain, Size: 2065 bytes --]

;;; print-tests.el --- tests for src/print.c         -*- lexical-binding: t; -*-

;; Copyright (C) 2014 Free Software Foundation, Inc.

;; This file is part of GNU Emacs.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Code:

(require 'ert)

(ert-deftest fresh-line ()
  (should (string= (with-output-to-string
                     (princ 'abc)
                     (should (fresh-line)))
                   "abc\n"))
  (should (string= (with-output-to-string
                     (should-not (fresh-line))
                     (princ 'xyz))
                   "xyz"))
  (message nil)
  (if noninteractive
      (progn (should            (fresh-line))
             (should-not        (fresh-line))
             (princ 'abc)
             (should            (fresh-line))
             (should-not        (fresh-line)))
    (should (string= (progn (should-not (fresh-line))
                            (princ 'abc)
                            (should (fresh-line))
                            (current-message))
                     "abc\n")))
  (let ((standard-output
         (with-current-buffer (get-buffer-create "*fresh-line-test*")
           (insert "--------")
           (point-max-marker))))
    (should     (fresh-line))
    (should-not (fresh-line))
    (should (string= (with-current-buffer (marker-buffer standard-output)
                       (buffer-string))
                     "--------\n"))))

(provide 'print-tests)
;;; print-tests.el ends here