json: some performance improvements.

diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor
index 8ebe2ee67f6ca4ec2b7bb360b9c8233d66ad2bdd..4990bc16abcac5a40698268c1e3f53ac0c4b39f2 100644 (file)
--- a/basis/json/reader/reader.factor
+++ b/basis/json/reader/reader.factor
@@ -1,66 +1,77 @@
 ! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
 ! See http://factorcode.org/license.txt for BSD license.
 
-USING: arrays assocs combinators fry hashtables io
-io.streams.string json kernel make math math.parser namespaces
-prettyprint sequences strings vectors ;
+USING: accessors arrays assocs combinators fry hashtables io
+io.streams.string json kernel kernel.private make math
+math.parser namespaces prettyprint sequences sequences.private
+strings vectors ;
 
 IN: json.reader
 
 <PRIVATE
 
-: value ( char -- num char )
-    1string " \t\r\n,:}]" read-until
+: value ( char stream -- num char )
+    [ 1string ] [ " \t\r\n,:}]" swap stream-read-until ] bi*
     [ append string>number ] dip ;
 
 DEFER: j-string%
 
-: j-escape% ( -- )
-    read1 {
+: j-escape% ( stream -- )
+    dup stream-read1 {
         { CHAR: b [ 8 ] }
         { CHAR: f [ 12 ] }
         { CHAR: n [ CHAR: \n ] }
         { CHAR: r [ CHAR: \r ] }
         { CHAR: t [ CHAR: \t ] }
-        { CHAR: u [ 4 read hex> ] }
+        { CHAR: u [ 4 over stream-read hex> ] }
         [ ]
-    } case [ , j-string% ] when* ;
+    } case [ , j-string% ] [ drop ] if* ;
 
-: j-string% ( -- )
-    "\\\"" read-until [ % ] dip
-    CHAR: \" = [ j-escape% ] unless ;
+: j-string% ( stream -- )
+    "\\\"" over stream-read-until [ % ] dip
+    CHAR: \" = [ drop ] [ j-escape% ] if ;
 
-: j-string ( -- str )
-    "\\\"" read-until CHAR: \" =
-    [ [ % j-escape% ] "" make ] unless ;
+: j-string ( stream -- str )
+    "\\\"" over stream-read-until CHAR: \" =
+    [ nip ] [ [ % j-escape% ] "" make ] if ;
 
-: second-last ( seq -- second-last )
-    [ length 2 - ] [ nth ] bi ; inline
+: second-last-unsafe ( seq -- second-last )
+    [ length 2 - ] [ nth-unsafe ] bi ; inline
+
+: pop-unsafe ( seq -- elt )
+    [ length 1 - ] keep [ nth-unsafe ] [ shorten ] 2bi ; inline
 
 ERROR: json-error ;
 
 : check-length ( seq n -- seq )
-    [ dup length ] [ >= ] bi* [ json-error ] unless ;
+    [ dup length ] [ >= ] bi* [ json-error ] unless
+    { vector } declare ; inline
 
 : v-over-push ( vec -- vec' )
-    2 check-length dup [ pop ] [ last ] bi push ;
+    2 check-length dup [ pop-unsafe ] [ last-unsafe ] bi
+    push ;
 
 : v-pick-push ( vec -- vec' )
-    3 check-length dup [ pop ] [ second-last ] bi push ;
+    3 check-length dup [ pop-unsafe ] [ second-last-unsafe ] bi
+    push ;
 
 : (close) ( accum -- accum' )
+    { vector } declare
     dup last V{ } = not [ v-over-push ] when ;
 
 : (close-array) ( accum -- accum' )
+    { vector } declare
     (close) dup pop >array suffix! ;
 
 : (close-hash) ( accum -- accum' )
-    (close) dup dup [ pop ] bi@ swap zip >hashtable suffix! ;
+    { vector } declare
+    (close) dup dup [ pop ] bi@ 2dup min-length <hashtable>
+    [ [ set-at ] curry 2each ] keep suffix! ;
 
-: scan ( accum char -- accum )
+: scan ( stream accum char -- stream accum )
     ! 2dup 1string swap . . ! Great for debug...
     {
-        { CHAR: \" [ j-string suffix! ] }
+        { CHAR: \" [ over j-string suffix! ] }
         { CHAR: [  [ V{ } clone suffix! ] }
         { CHAR: ,  [ v-over-push ] }
         { CHAR: ]  [ (close-array) ] }
@@ -71,17 +82,20 @@ ERROR: json-error ;
         { CHAR: \t [ ] }
         { CHAR: \r [ ] }
         { CHAR: \n [ ] }
-        { CHAR: t  [ 3 read drop t suffix! ] }
-        { CHAR: f  [ 4 read drop f suffix! ] }
-        { CHAR: n  [ 3 read drop json-null suffix! ] }
-        [ value [ suffix! ] dip [ scan ] when*  ]
+        { CHAR: t  [ 3 pick stream-read drop t suffix! ] }
+        { CHAR: f  [ 4 pick stream-read drop f suffix! ] }
+        { CHAR: n  [ 3 pick stream-read drop json-null suffix! ] }
+        [ pick value [ suffix! ] dip [ scan ] when*  ]
     } case ;
 
+: stream-json-read ( stream -- objects )
+    V{ } clone over '[ _ stream-read1 dup ]
+    [ scan ] while drop nip ;
+
 PRIVATE>
 
 : read-jsons ( -- objects )
-    V{ } clone input-stream get
-    '[ _ stream-read1 dup ] [ scan ] while drop ;
+    input-stream get stream-json-read ;
 
 : json> ( string -- object )
     [ read-jsons first ] with-string-reader ;

diff --git a/basis/json/writer/writer.factor b/basis/json/writer/writer.factor
index 165bd8638725792ccf5ab7fd56b9e7a081053493..df02e43608497c5064c2ce7a404502c51c3c0e4a 100644 (file)
--- a/basis/json/writer/writer.factor
+++ b/basis/json/writer/writer.factor
@@ -6,41 +6,45 @@ prettyprint hashtables mirrors tr json fry combinators ;
 IN: json.writer
 
 #! Writes the object out to a stream in JSON format
-GENERIC: json-print ( obj -- )
+GENERIC# stream-json-print 1 ( obj stream -- )
+
+: json-print ( obj -- )
+    output-stream get stream-json-print ;
 
 : >json ( obj -- string )
     #! Returns a string representing the factor object in JSON format
     [ json-print ] with-string-writer ;
 
-M: f json-print ( f -- )
-    drop "false" write ;
+M: f stream-json-print
+    [ drop "false" ] [ stream-write ] bi* ;
 
-M: t json-print ( t -- )
-    drop "true" write ;
+M: t stream-json-print
+    [ drop "true" ] [ stream-write ] bi* ;
 
-M: json-null json-print ( null -- )
-    drop "null" write ;
+M: json-null stream-json-print
+    [ drop "null" ] [ stream-write ] bi* ;
 
-M: string json-print ( obj -- )
-    CHAR: " write1 [
+M: string stream-json-print
+    CHAR: " over stream-write1 swap [
         {
-            { CHAR: "  [ "\\\"" write ] }
+            { CHAR: "  [ "\\\"" over stream-write ] }
             { CHAR: \r [ ] }
-            { CHAR: \n [ "\\r\\n" write ] }
-            [ write1 ]
+            { CHAR: \n [ "\\r\\n" over stream-write ] }
+            [ over stream-write1 ]
         } case
-    ] each CHAR: " write1 ;
+    ] each CHAR: " swap stream-write1 ;
 
-M: integer json-print ( num -- )
-    number>string write ;
+M: integer stream-json-print
+    [ number>string ] [ stream-write ] bi* ;
 
-M: real json-print ( num -- )
-    >float number>string write ;
+M: real stream-json-print
+    [ >float number>string ] [ stream-write ] bi* ;
 
-M: sequence json-print ( array -- )
-    CHAR: [ write1 [
-        [ CHAR: , write1 ] [ json-print ] interleave
-    ] unless-empty CHAR: ] write1 ;
+M: sequence stream-json-print
+    CHAR: [ over stream-write1 swap [
+        over '[ CHAR: , _ stream-write1 ]
+        pick '[ _ stream-json-print ] interleave
+    ] unless-empty CHAR: ] swap stream-write1 ;
 
 SYMBOL: jsvar-encode?
 t jsvar-encode? set-global
@@ -48,31 +52,33 @@ TR: jsvar-encode "-" "_" ;
 
 <PRIVATE
 
-: json-print-assoc ( assoc -- )
-    CHAR: { write1 >alist [
+: json-print-assoc ( assoc stream -- )
+    CHAR: { over stream-write1 swap >alist [
         jsvar-encode? get [
-            [ CHAR: , write1 ]
-            [
+            over '[ CHAR: , _ stream-write1 ]
+            pick dup '[
                 first2
-                [ jsvar-encode json-print ]
-                [ CHAR: : write1 json-print ]
+                [ jsvar-encode _ stream-json-print ]
+                [ _ CHAR: : over stream-write1 stream-json-print ]
                 bi*
             ] interleave
         ] [
-            [ CHAR: , write1 ]
-            [
+            over '[ CHAR: , _ stream-write1 ]
+            pick dup '[
                 first2
-                [ json-print ]
-                [ CHAR: : write1 json-print ]
+                [ _ stream-json-print ]
+                [ _ CHAR: : over stream-write1 stream-json-print ]
                 bi*
             ] interleave
         ] if
-    ] unless-empty CHAR: } write1 ;
+    ] unless-empty CHAR: } swap stream-write1 ;
 
 PRIVATE>
 
-M: tuple json-print ( tuple -- ) <mirror> json-print-assoc ;
+M: tuple stream-json-print
+    [ <mirror> ] dip json-print-assoc ;
 
-M: hashtable json-print ( hashtable -- ) json-print-assoc ;
+M: hashtable stream-json-print json-print-assoc ;
 
-M: word json-print name>> json-print ;
+M: word stream-json-print
+    [ name>> ] dip stream-json-print ;