# HG changeset patch
# User Aidan Kehoe <kehoea@parhasard.net>
# Date 1387708593 0
# Node ID 4004c3266c09888a9935242a462beb3fb28e02a3
# Parent  7a538e1a4676a2229b4f1806dfa26725226f0ba7
Transform #'princ to #'write-sequence at compile time if appropriate.

lisp/ChangeLog addition:

2013-12-22  Aidan Kehoe  <kehoea@parhasard.net>

	* cl-macs.el:
	* cl-macs.el (princ): New compiler macro.
	Transform #'princ to #'write-sequence if we can determine at
	compile time that it is being passed a string. Initialising the
	printer is expensive enough, but much of our code took this
	approach because #'write-sequence wasn't available.

diff -r 7a538e1a4676 -r 4004c3266c09 lisp/ChangeLog
--- a/lisp/ChangeLog	Thu Dec 19 18:13:11 2013 +0000
+++ b/lisp/ChangeLog	Sun Dec 22 10:36:33 2013 +0000
@@ -1,3 +1,12 @@
+2013-12-22  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* cl-macs.el:
+	* cl-macs.el (princ): New compiler macro.
+	Transform #'princ to #'write-sequence if we can determine at
+	compile time that it is being passed a string. Initialising the
+	printer is expensive enough, but much of our code took this
+	approach because #'write-sequence wasn't available.
+
 2013-12-17  Aidan Kehoe  <kehoea@parhasard.net>
 
 	* simple.el (blink-matching-open):
diff -r 7a538e1a4676 -r 4004c3266c09 lisp/cl-macs.el
--- a/lisp/cl-macs.el	Thu Dec 19 18:13:11 2013 +0000
+++ b/lisp/cl-macs.el	Sun Dec 22 10:36:33 2013 +0000
@@ -3911,6 +3911,28 @@
       (list* 'intersection (pop cl-keys) (pop cl-keys) :stable t cl-keys)
     form))
 
+(define-compiler-macro princ (&whole form object &optional stream)
+  "When passing `princ' a string, call `write-sequence' instead.
+
+This avoids the resource- and time-intensive initialization of the printer,
+and functions equivalently. Such code will not run on 21.4, but 21.4 will
+not normally encounter it, and the error message will be clear enough (that
+`write-sequence' has a void function definition) in the odd event that it
+does."
+  (cond ((not (<= 2 (length form) 3))
+	 form)
+	((or (stringp object)
+	     (member (car-safe object)
+		     '(buffer-string buffer-substring concat format gettext
+		       key-description make-string mapconcat
+		       substitute-command-keys substring-no-properties
+		       symbol-name text-char-description string)))
+	 (cons 'write-sequence (cdr form)))
+	((member (car-safe object) '(substring subseq))
+	 `(write-sequence ,(nth 1 object) ,stream :start ,(nth 2 object)
+	                  ,@(if (nth 3 object) `((:end ,(nth 3 object))))))
+	(t form)))
+
 (map nil
      #'(lambda (function)
          ;; There are byte codes for the two-argument versions of these