1.0.26.21: fix ERROR leaking memory

[sbcl.git] / src / code / print.lisp

diff --git a/src/code/print.lisp b/src/code/print.lisp
index e9b58d0..84f557a 100644 (file)
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -129,6 +129,27 @@
 \f
 ;;;; routines to print objects
 
+\f
+;;; keyword variables shared by WRITE and WRITE-TO-STRING, and
+;;; the bindings they map to.
+(eval-when (:compile-toplevel :load-toplevel)
+  (defvar *printer-keyword-variables*
+    '(:escape *print-escape*
+      :radix *print-radix*
+      :base *print-base*
+      :circle *print-circle*
+      :pretty *print-pretty*
+      :level *print-level*
+      :length *print-length*
+      :case *print-case*
+      :array *print-array*
+      :gensym *print-gensym*
+      :readably *print-readably*
+      :right-margin *print-right-margin*
+      :miser-width *print-miser-width*
+      :lines *print-lines*
+      :pprint-dispatch *print-pprint-dispatch*)))
+
 (defun write (object &key
                      ((:stream stream) *standard-output*)
                      ((:escape *print-escape*) *print-escape*)
@@ -154,6 +175,32 @@
   (output-object object (out-synonym-of stream))
   object)
 
+;;; Optimize common case of constant keyword arguments
+(define-compiler-macro write (&whole form object &rest keys)
+  (let (bind ignore)
+    (do ()
+        ((not (cdr keys))
+         ;; Odd number of keys, punt
+         (when keys
+           (return-from write form)))
+      (let* ((key (pop keys))
+             (value (pop keys))
+             (variable (or (getf *printer-keyword-variables* key)
+                           (when (eq :stream key)
+                             'stream)
+                           (return-from write form))))
+        (when (assoc variable bind)
+          ;; First key has precedence, but we still need to execute the
+          ;; argument, and in the right order.
+          (setf variable (gensym "IGNORE"))
+          (push variable ignore))
+        (push (list variable value) bind)))
+    (unless (assoc 'stream bind)
+      (push (list 'stream '*standard-output*) bind))
+    `(let ,(nreverse bind)
+       ,@(when ignore `((declare (ignore ,@ignore))))
+       (output-object ,object stream))))
+
 (defun prin1 (object &optional stream)
   #!+sb-doc
   "Output a mostly READable printed representation of OBJECT on the specified
@@ -192,27 +239,51 @@
   (values))
 
 (defun write-to-string
-       (object &key
-               ((:escape *print-escape*) *print-escape*)
-               ((:radix *print-radix*) *print-radix*)
-               ((:base *print-base*) *print-base*)
-               ((:circle *print-circle*) *print-circle*)
-               ((:pretty *print-pretty*) *print-pretty*)
-               ((:level *print-level*) *print-level*)
-               ((:length *print-length*) *print-length*)
-               ((:case *print-case*) *print-case*)
-               ((:array *print-array*) *print-array*)
-               ((:gensym *print-gensym*) *print-gensym*)
-               ((:readably *print-readably*) *print-readably*)
-               ((:right-margin *print-right-margin*) *print-right-margin*)
-               ((:miser-width *print-miser-width*) *print-miser-width*)
-               ((:lines *print-lines*) *print-lines*)
-               ((:pprint-dispatch *print-pprint-dispatch*)
-                *print-pprint-dispatch*))
+    (object &key
+            ((:escape *print-escape*) *print-escape*)
+            ((:radix *print-radix*) *print-radix*)
+            ((:base *print-base*) *print-base*)
+            ((:circle *print-circle*) *print-circle*)
+            ((:pretty *print-pretty*) *print-pretty*)
+            ((:level *print-level*) *print-level*)
+            ((:length *print-length*) *print-length*)
+            ((:case *print-case*) *print-case*)
+            ((:array *print-array*) *print-array*)
+            ((:gensym *print-gensym*) *print-gensym*)
+            ((:readably *print-readably*) *print-readably*)
+            ((:right-margin *print-right-margin*) *print-right-margin*)
+            ((:miser-width *print-miser-width*) *print-miser-width*)
+            ((:lines *print-lines*) *print-lines*)
+            ((:pprint-dispatch *print-pprint-dispatch*)
+             *print-pprint-dispatch*))
   #!+sb-doc
   "Return the printed representation of OBJECT as a string."
   (stringify-object object))
 
+;;; Optimize common case of constant keyword arguments
+(define-compiler-macro write-to-string (&whole form object &rest keys)
+  (let (bind ignore)
+    (do ()
+        ((not (cdr keys))
+         ;; Odd number of keys, punt
+         (when keys
+           (return-from write-to-string form)))
+      (let* ((key (pop keys))
+             (value (pop keys))
+             (variable (or (getf *printer-keyword-variables* key)
+                           (return-from write-to-string form))))
+        (when (assoc variable bind)
+          ;; First key has precedence, but we still need to execute the
+          ;; argument, and in the right order.
+          (setf variable (gensym "IGNORE"))
+          (push variable ignore))
+        (push (list variable value) bind)))
+    (if bind
+        `(let ,(nreverse bind)
+           ,@(when ignore `((declare (ignore ,@ignore))))
+           (stringify-object ,object))
+        `(stringify-object ,object))))
+
 (defun prin1-to-string (object)
   #!+sb-doc
   "Return the printed representation of OBJECT as a string with
@@ -376,8 +447,6 @@
         (output-float object stream))
        (ratio
         (output-ratio object stream))
-       (ratio
-        (output-ratio object stream))
        (complex
         (output-complex object stream))))
     (character
@@ -908,7 +977,8 @@
                ;; this for now. [noted by anonymous long ago] -- WHN 19991130
                `(or (char= ,char #\\)
                  (char= ,char #\"))))
-    (with-array-data ((data string) (start) (end (length string)))
+    (with-array-data ((data string) (start) (end)
+                      :check-fill-pointer t)
       (do ((index start (1+ index)))
           ((>= index end))
         (let ((char (schar data index)))