[bknr-cvs] hans changed trunk/libraries/yason/encode.lisp

[BKNR Commits]

Revision: 4090
Author: hans
URL: http://bknr.net/trac/changeset/4090

Optimize encoder for a 100x speedup.  Don't use PRINC unless you know
that you need it.

U   trunk/libraries/yason/encode.lisp

Modified: trunk/libraries/yason/encode.lisp
===================================================================
--- trunk/libraries/yason/encode.lisp	2008-11-27 12:18:22 UTC (rev 4089)
+++ trunk/libraries/yason/encode.lisp	2008-11-27 14:13:59 UTC (rev 4090)
@@ -17,99 +17,100 @@
 
   (:documentation "Encode OBJECT to STREAM in JSON format.  May be
   specialized by applications to perform specific rendering.  STREAM
-  defaults to *STANDARD-OUTPUT*.")
+  defaults to *STANDARD-OUTPUT*."))
 
-  (:method ((object string) &optional (stream *standard-output*))
-    (with-standard-output-to (stream)
-      (princ #\")
-      (loop
-         for char across object
-         do (case char
-              ((#\\ #\" #\/)
-               (princ #\\) (princ char))
-              (#\Backspace
-               (princ #\\) (princ #\b))
-              (#\Page
-               (princ #\\) (princ #\f))
-              (#\Newline
-               (princ #\\) (princ #\n))
-              (#\Return
-               (princ #\\) (princ #\r))
-              (#\Tab
-               (princ #\\) (princ #\t))
-              (t
-               (princ char))))
-      (princ #\"))
-    object)
+(defparameter *char-replacements*
+  (alexandria:plist-hash-table
+   '(#\\ "\\\\"
+     #\" "\\\""
+     #\/ "\\/"
+     #\Backspace "\\b"
+     #\Page "\\f"
+     #\Newline "\\n"
+     #\Return "\\r"
+     #\Tab "\\t")))
+       
 
-  (:method ((object rational) &optional (stream *standard-output*))
-    (encode (float object) stream)
-    object)
+(defmethod encode ((string string) &optional (stream *standard-output*))
+  (with-standard-output-to (stream)
+    (write-char #\")
+    (dotimes (i (length string))
+      (let* ((char (aref string i))
+             (replacement (gethash char *char-replacements*)))
+        (if replacement
+            (write-string replacement)
+            (write-char char))))
+    (write-char #\")
+    string))
 
-  (:method ((object integer) &optional (stream *standard-output*))
-    (princ object stream))
+(defmethod encode ((object rational) &optional (stream *standard-output*))
+  (encode (float object) stream)
+  object)
 
-  (:method ((object hash-table) &optional (stream *standard-output*))
-    (with-standard-output-to (stream)
-      (princ #\{)
-      (let (printed)
-        (maphash (lambda (key value)
-                   (if printed
-                       (princ #\,)
-                       (setf printed t))
-                   (encode key stream)
-                   (princ #\:)
-                   (encode value stream))
-                 object))
-      (princ #\}))
-    object)
+(defmethod encode ((object integer) &optional (stream *standard-output*))
+  (princ object stream))
 
-  (:method ((object vector) &optional (stream *standard-output*))
-    (with-standard-output-to (stream)
-      (princ #\[)
-      (let (printed)
-        (loop
-           for value across object
-           do
-             (when printed
-               (princ #\,))
-             (setf printed t)
-             (encode value stream)))
-      (princ #\]))
-    object)
+(defmethod encode ((object hash-table) &optional (stream *standard-output*))
+  (with-standard-output-to (stream)
+    (write-char #\{)
+    (let (printed)
+      (maphash (lambda (key value)
+                 (if printed
+                     (write-char #\,)
+                     (setf printed t))
+                 (encode key stream)
+                 (write-char #\:)
+                 (encode value stream))
+               object))
+    (write-char #\}))
+  object)
 
-  (:method ((object list) &optional (stream *standard-output*))
-    (with-standard-output-to (stream)
-      (princ #\[)
-      (let (printed)
-        (dolist (value object)
-          (if printed
-              (princ #\,)
-              (setf printed t))
-          (encode value stream)))
-      (princ #\]))
-    object)
+(defmethod encode ((object vector) &optional (stream *standard-output*))
+  (with-standard-output-to (stream)
+    (write-char #\[)
+    (let (printed)
+      (loop
+         for value across object
+         do
+         (when printed
+           (write-char #\,))
+         (setf printed t)
+         (encode value stream)))
+    (write-char #\]))
+  object)
 
-  (:method ((object (eql 'true)) &optional (stream *standard-output*))
-    (princ "true" stream)
-    object)
+(defmethod encode ((object list) &optional (stream *standard-output*))
+  (with-standard-output-to (stream)
+    (write-char #\[)
+    (let (printed)
+      (dolist (value object)
+        (if printed
+            (write-char #\,)
+            (setf printed t))
+        (encode value stream)))
+    (write-char #\]))
+  object)
 
-  (:method ((object (eql 'false)) &optional (stream *standard-output*))
-    (princ "false" stream)
-    object)
+(defmethod encode ((object (eql 'true)) &optional (stream *standard-output*))
+  (write-string "true" stream)
+  object)
 
-  (:method ((object (eql 'null)) &optional (stream *standard-output*))
-    (princ "null" stream)
-    object)
+(defmethod encode ((object (eql 'false)) &optional (stream *standard-output*))
+  (write-string "false" stream)
+  object)
 
-  (:method ((object (eql t)) &optional (stream *standard-output*))
-    (princ "true" stream)
-    object)
+(defmethod encode ((object (eql 'null)) &optional (stream *standard-output*))
+  (write-string "null" stream)
+  object)
 
-  (:method ((object (eql nil)) &optional (stream *standard-output*))
-    (princ "null" stream)
-    object))
+(defmethod encode ((object (eql t)) &optional (stream *standard-output*))
+  (write-string "true" stream)
+  object)
 
+(defmethod encode ((object (eql nil)) &optional (stream *standard-output*))
+  (write-string "null" stream)
+  object)
+
 (defclass json-output-stream ()
   ((output-stream :reader output-stream
                   :initarg :output-stream)
@@ -119,7 +120,7 @@
 
 (defun next-aggregate-element ()
   (if (car (stack *json-output*))
-      (princ (car (stack *json-output*)) (output-stream *json-output*))
+      (write-char (car (stack *json-output*)) (output-stream *json-output*))
       (setf (car (stack *json-output*)) #\,)))
 
 (defmacro with-output ((stream) &body body)
@@ -147,12 +148,12 @@
        (error 'no-json-output-context))
      (when (stack *json-output*)
        (next-aggregate-element))
-     (princ ,begin-char (output-stream *json-output*))
+     (write-char ,begin-char (output-stream *json-output*))
      (push nil (stack *json-output*))
      (prog1
          (progn , at body)
        (pop (stack *json-output*))
-       (princ ,end-char (output-stream *json-output*)))))
+       (write-char ,end-char (output-stream *json-output*)))))
 
 (defmacro with-array (() &body body)
   "Open a JSON array, then run BODY.  Inside the body,
@@ -188,7 +189,7 @@
 type for which an ENCODE method is defined."
   (next-aggregate-element)
   (encode key (output-stream *json-output*))
-  (princ #\: (output-stream *json-output*))
+  (write-char #\: (output-stream *json-output*))
   (encode value (output-stream *json-output*))
   value)