From 5185986c75b5c2cbc2114e867e1a5cd64c49de06 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 20 Sep 2010 07:33:24 +0000
Subject: [PATCH] 1.0.42.46: style-warn users about READ-FROM-STRING &optional
 gotcha

 Check -- at runtime if need be! -- if the EOF-ERROR-P argument to
 READ-FROM-STRING is one of its keyword arguments, and signal a
 style-warning explaining the issue if so,

 Since the runtime check surprisingly has a measurable cost, add a
 compiler-macro that

  * signals the style-warning at compile-time.

  * rewrites the call into required-args-only form.

 Which actually nets us a 2% speedup... perhaps we should consider
 more widespread rewriting of &KEY calls into required-args-only form.
---
 src/code/reader.lisp |   70 ++++++++++++++++++++++++++++++++++++++++++++------
 version.lisp-expr    |    2 +-
 2 files changed, 63 insertions(+), 9 deletions(-)

diff --git a/src/code/reader.lisp b/src/code/reader.lisp
index 27ec01a..7cdd79b 100644
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -1542,14 +1542,19 @@ standard Lisp readtable when NIL."
 
 ;;;; READ-FROM-STRING
 
-(defun read-from-string (string &optional (eof-error-p t) eof-value
-                                &key (start 0) end
-                                preserve-whitespace)
-  #!+sb-doc
-  "The characters of string are successively given to the lisp reader
-   and the lisp object built by the reader is returned. Macro chars
-   will take effect."
-  (declare (string string))
+(defun maybe-note-read-from-string-signature-issue (eof-error-p)
+  ;; The interface is so unintuitive that we explicitly check for the common
+  ;; error.
+  (when (member eof-error-p '(:start :end :preserve-whitespace))
+    (style-warn "~@<~S as EOF-ERROR-P argument to ~S: probable error. ~
+               Two optional arguments must be provided before the ~
+               first keyword argument.~:@>"
+                eof-error-p 'read-from-string)
+    t))
+
+(declaim (ftype (sfunction (string t t index (or null index) t) (values t index))
+                %read-from-string))
+(defun %read-from-string (string eof-error-p eof-value start end preserve-whitespace)
   (with-array-data ((string string :offset-var offset)
                     (start start)
                     (end end)
@@ -1559,6 +1564,55 @@ standard Lisp readtable when NIL."
                   (%read-preserving-whitespace stream eof-error-p eof-value nil)
                   (read stream eof-error-p eof-value))
               (- (string-input-stream-current stream) offset)))))
+
+(defun read-from-string (string &optional (eof-error-p t) eof-value
+                                &key (start 0) end preserve-whitespace)
+  #!+sb-doc
+  "The characters of string are successively given to the lisp reader
+   and the lisp object built by the reader is returned. Macro chars
+   will take effect."
+  (declare (string string))
+  (maybe-note-read-from-string-signature-issue eof-error-p)
+  (%read-from-string string eof-error-p eof-value start end preserve-whitespace))
+
+(define-compiler-macro read-from-string (&whole form string &rest args)
+  ;; Check this at compile-time, and rewrite it so we're silent at runtime.
+  (destructuring-bind (&optional eof-error-p eof-value &rest keys)
+      args
+    (cond ((maybe-note-read-from-string-signature-issue eof-error-p)
+           `(read-from-string ,string t ,eof-value ,@keys))
+          (t
+           (let* ((start (gensym "START"))
+                  (end (gensym "END"))
+                  (preserve-whitespace (gensym "PRESERVE-WHITESPACE"))
+                  bind seen ignore)
+             (do ()
+                 ((not (cdr keys))
+                  ;; Odd number of keys, punt.
+                  (when keys (return-from read-from-string form)))
+               (let* ((key (pop keys))
+                      (value (pop keys))
+                      (var (case key
+                             (:start start)
+                             (:end end)
+                             (:preserve-whitespace preserve-whitespace)
+                             (otherwise
+                              (return-from read-from-string form)))))
+                 (when (assoc key seen)
+                   (setf var (gensym "IGNORE"))
+                   (push var ignore))
+                 (push key seen)
+                 (push (list var value) bind)))
+             (dolist (default (list (list start 0)
+                                    (list end nil)
+                                    (list preserve-whitespace nil)))
+               (unless (assoc (car default) bind)
+                 (push default bind)))
+             (once-only ((string string))
+               `(let ,(nreverse bind)
+                  ,@(when ignore `((declare (ignore ,@ignore))))
+                  (%read-from-string ,string ,eof-error-p ,eof-value
+                                     ,start ,end ,preserve-whitespace))))))))
 
 ;;;; PARSE-INTEGER
 
diff --git a/version.lisp-expr b/version.lisp-expr
index a43766b..62ccde6 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.42.45"
+"1.0.42.46"
-- 
1.7.10.4