[Sbcl-commits] master: Macroize WRITE[-TO-STRING] defknowns, the latter missing a keyword

[Douglas K. <sn...@us...>]

The branch "master" has been updated in SBCL:
       via  03ceb401c80949b4c1e3abd419dd2409685b85d7 (commit)
      from  4e815e8a8ea12f266699f1e53a94e2303bd19ea8 (commit)

- Log -----------------------------------------------------------------
commit 03ceb401c80949b4c1e3abd419dd2409685b85d7
Author: Douglas Katzman <do...@go...>
Date:   Thu Apr 3 11:26:31 2014 -0400

    Macroize WRITE[-TO-STRING] defknowns, the latter missing a keyword
    
    ... which was recently corrected for one and not the other.
---
 src/compiler/fndb.lisp |   55 +++++++++++++++++++++---------------------------
 1 files changed, 24 insertions(+), 31 deletions(-)

diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 2d0724b..c2bb501 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1148,29 +1148,6 @@
 
 (defknown read-byte (stream &optional t t) t (explicit-check))
 
-(defknown write
-  (t &key
-     (:stream stream-designator)
-     (:escape t)
-     (:radix t)
-     (:base (integer 2 36))
-     (:circle t)
-     (:pretty t)
-     (:level (or unsigned-byte null))
-     (:readably t)
-     (:length (or unsigned-byte null))
-     (:case t)
-     (:array t)
-     (:gensym t)
-     (:lines (or unsigned-byte null))
-     (:right-margin (or unsigned-byte null))
-     (:miser-width (or unsigned-byte null))
-     (:pprint-dispatch t)
-     (:suppress-errors t))
-  t
-  (any explicit-check)
-  :derive-type #'result-type-first-arg)
-
 (defknown (prin1 print princ) (t &optional stream-designator)
   t
   (any explicit-check)
@@ -1179,17 +1156,33 @@
 (defknown (pprint) (t &optional stream-designator) (values)
   (explicit-check))
 
+(macrolet
+    ((deffrob (name keys returns attributes &rest more)
+       `(defknown ,name
+            (t &key ,@keys
+               (:escape t)
+               (:radix t)
+               (:base (integer 2 36))
+               (:circle t)
+               (:pretty t)
+               (:readably t)
+               (:level (or unsigned-byte null))
+               (:length (or unsigned-byte null))
+               (:case t)
+               (:array t)
+               (:gensym t)
+               (:lines (or unsigned-byte null))
+               (:right-margin (or unsigned-byte null))
+               (:miser-width (or unsigned-byte null))
+               (:pprint-dispatch t)
+               (:suppress-errors t))
+          ,returns ,attributes ,@more)))
+  (deffrob write ((:stream stream-designator)) t (any explicit-check)
+    :derive-type #'result-type-first-arg)
 ;;; xxx-TO-STRING functions are not foldable because they depend on
 ;;; the dynamic environment, the state of the pretty printer dispatch
 ;;; table, and probably other run-time factors.
-(defknown write-to-string
-  (t &key (:escape t) (:radix t) (:base (integer 2 36)) (:readably t)
-     (:circle t) (:pretty t) (:level (or unsigned-byte null))
-     (:length (or unsigned-byte null)) (:case t) (:array t) (:gensym t)
-     (:lines (or unsigned-byte null)) (:right-margin (or unsigned-byte null))
-     (:miser-width (or unsigned-byte null)) (:pprint-dispatch t))
-  simple-string
-  (flushable explicit-check))
+  (deffrob write-to-string () simple-string (flushable explicit-check)))
 
 (defknown (prin1-to-string princ-to-string) (t) simple-string (flushable))
 

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL