Remove old JSON code

@@ -43,2 +46,3 @@
+  ;; returns nibble (0..15) or #f if char is not a hex digit
   (let (i (char->integer char))
-    (and (fx< i (u8vector-length unhexes))
+    (and (fx< i 123) ;; 123 == (u8vector-length unhexes)

@@ -13,0 +7,4 @@
+        :std/list/walist
+        :std/encoding/hex
+        ./env)
+(export __parse-json)

@@ -13,0 +18,4 @@
+
+;;; whitespace
+
+(def (__skip-whitespace (reader : BufferedReader))

@@ -0,0 +36,4 @@
+       (writer.write-json obj ctx)
+       (get-memory-output-string-utf8 writer)))
+    ((and (output-port? writer) (not (binary-port? writer)))
+     (display (write-json #f obj ctx) writer))

@@ -31,0 +34,4 @@
+;;;
+
+;;; escape callback for write-string/escape: returns :fixnum or #f
+(def (json-string-escape (writer :- BufferedWriter) (u8 :- :fixnum))

@@ -68,3 +68,3 @@
 		            result))))
 	     (['int arg how flags width]
-	      (with-syntax ((ctx ctx) (arg arg) (how how) (flags flags) (width width) (writer writer))
+	      (with-syntax ((ctx ctx) (arg arg) (how how) (flags (datum->syntax ctx (list 'quote flags))) (width width) (writer writer))

@@ -78,3 +78,3 @@
 		            result))))
 	     (['float arg how flags width precision result]
-	      (with-syntax ((ctx ctx) (arg arg) (how how) (flags flags) (width width) (precision precision) (writer writer))
+	      (with-syntax ((ctx ctx) (arg arg) (how how) (flags (datum->syntax ctx (list 'quote flags))) (width width) (precision precision) (writer writer))

@@ -84,1 +85,3 @@
-         (begin
+            (wr      (__print-float str-buf fmt-buf num))
+            (buflen  (u8vector-length str-buf)))
+       (cond

@@ -47,3 +49,1 @@
-      (let (read (DatagramSocket-recvfrom sock peer buffer))
-        (DatagramSocket-sendto sock (unbox peer) buffer 0 read)
-        (lp)))))
+  (with-catch

@@ -341,0 +357,4 @@
+;;; Continuations are applied to s1's mismatch index;
+;;; in the case of equality, this is END1.
+
+(def (%string-compare s1 start1 end1 s2 start2 end2

@@ -0,0 +26,4 @@
+
+(declare (not safe))
+
+(defstruct evector ((vector : :vector)

@@ -0,0 +31,4 @@
+  transparent: #t
+  constructor: :init!)
+
+(defstruct eu8vector ((u8vector : :u8vector)

@@ -0,0 +36,4 @@
+  transparent: #t
+  constructor: :init!)
+
+(defstruct ebits ((bits : :u8vector)

@@ -0,0 +118,4 @@
+;;;   %SMALLEST-LENGTH takes care of the type checking -- which is what
+;;;   the CALLEE argument is for --; thus, the design is tuned for
+;;;   avoiding redundant type checks.
+(define %smallest-length

@@ -264,6 +264,17 @@ namespace: #f
             1))
          (field-info-length (##fx* 3 (##fx- (##vector-length slot-vector) first-new-field)))
          (field-info (make-vector field-info-length #f))
+         (__field-info-init

@@ -338,0 +354,4 @@
+;;                 name    = (vector-ref (##type-fields type) (fx* field-index 3))
+;;                 flags   = (vector-ref (##type-fields type) (fx+ (fx* field-index 3) 1))
+;;                 default = (vector-ref (##type-fields type) (fx+ (fx* field-index 3) 2))
+(def (struct-field-fold klass kons knil)

@@ -30,0 +42,4 @@
+            (loop (fx1+ i)))
+          unhexes))))
+  (def length-unhexes% (u8vector-length unhexes%))) ;; 103
+(defsyntax unhexes (lambda (stx) unhexes%))

@@ -30,0 +43,4 @@
+          unhexes))))
+  (def length-unhexes% (u8vector-length unhexes%))) ;; 103
+(defsyntax unhexes (lambda (stx) unhexes%))
+(defsyntax length-unhexes (lambda (stx) length-unhexes%))

@@ -13,0 +72,4 @@
+        (when key
+          ;; If you see a duplicate key, it's as likely an attack as a bug. #LangSec
+          (if (key? key)
+            (error "Duplicate hash key in JSON input" key)

@@ -13,0 +96,4 @@
+        (when key
+          ;; If you see a duplicate key, it's as likely an attack as a bug. #LangSec
+          (if (key? key)
+            (error "Duplicate hash key in JSON input" key)

@@ -13,0 +119,4 @@
+        (if key
+          ;; If you see a duplicate key, it's as likely an attack as a bug. #LangSec
+          (if (key? key)
+            (error "Duplicate hash key in JSON input" key)

@@ -13,0 +142,4 @@
+        (if key
+          ;; If you see a duplicate key, it's as likely an attack as a bug. #LangSec
+          (if (key? key)
+            (error "Duplicate hash key in JSON input" key)

@@ -0,0 +110,4 @@
+  (walist
+   (with ([strukt . fields] (struct->list struct))
+     (with-list-builder (c)
+       (struct-field-fold

@@ -31,0 +71,4 @@
+         (fx+ n (if (fx< n 10) #x30 #x37)))
+       (do-write (wr 0)
+         (writer.write-backslash)
+         (writer.write-u8 117) ; u

@@ -42,0 +107,4 @@
+
+(def (write-json-float (writer : BufferedWriter)
+                       (obj :~ (? (and flonum? finite?)) :- :flonum)) => :fixnum
+  (let ((s (number->string obj)))

@@ -152,3 +188,1 @@
-;; builtin objects
-(defjson-writer :t (write-json-t writer obj env)
-  (using (klass (class-of obj) :- :class)
+(def (write-json-object (writer : BufferedWriter) obj (ctx : JSONWriteContext)) => :fixnum

@@ -158,0 +224,4 @@
+    (writer.write-string-utf8 "false"))
+   ((void? obj)
+    (writer.write-string-utf8 "null"))
+   ((method-ref obj ':write-json)

@@ -69,2 +66,2 @@
-	     (['int arg how flags width]
-	      (with-syntax ((ctx ctx) (arg arg) (how how) (flags flags) (width width) (writer writer))
+	     (['int arg how flags width precision]
+	      (let (conv (case how

@@ -93,3 +96,3 @@
                       (cons (case how
 			      ((#\a) #'(format-display writer arg ctx))
-			      ((#\s) #'(format-write writer arg ctx))
+			      ((#\s #\w) #'(format-write writer arg ctx))

@@ -80,3 +79,3 @@
                 (case how
                   ((#\a) (format-display writer arg fmt.env))
-                  ((#\s) (format-write   writer arg fmt.env))
+                  ((#\s #\w) (format-write   writer arg fmt.env))

@@ -351,0 +309,4 @@
+             ;; Write Scheme prefix (#x/#o/#b); contributes 0 if no # flag or decimal.
+             (def (write-prefix!)
+               (if prefix-char
+                 (begin (writer.write-sharp) (writer.write-u8 prefix-char) 2)

@@ -36,3 +36,3 @@
              (fx+ i 1))))))
 
-   (def (buffer-cache-get-float-format-buffer (opt : FormatOpt) (num : :flonum)) => :u8vector
+   (def (buffer-cache-get-float-format-buffer flags width precision (flonum-repr :- :fixnum)) => :u8vector

@@ -64,0 +61,4 @@
+            (int-part-reserve
+             (if (or (fx= flonum-repr (@char->int #\f))
+                     (fx= flonum-repr (@char->int #\F)))
+               313 0))

@@ -82,3 +82,1 @@
-            (wr      (__print-float str-buf fmt-buf num)))
-       (defrule (release!)
-         (begin
+   (defwriter-ext (format-float writer (num : :flonum) flags width precision (flonum-repr :- :fixnum))

@@ -85,0 +86,4 @@
+            (buflen  (u8vector-length str-buf)))
+       (cond
+        ((fx<= wr 0)
+         (buffer-cache.put! str-buf)

@@ -94,0 +96,4 @@
+        (else
+         ;; Buffer too small — shouldn't happen with correct formula, but retry gracefully.
+         (buffer-cache.put! str-buf)
+         (let* ((str-buf2 (make-u8vector (fx+ wr 1)))

@@ -125,3 +125,3 @@
 ;; *one* possible key for each value.
 ;; : (Table K V) <- (Table V K) to: (Optional (Table K V))
-(def (invert-hash (from : HashTable) (to : HashTable := (HashTable-new from)))
+(def (invert-hash (from : HashTable) to: (to : HashTable := (HashTable-new from)))

@@ -139,2 +151,2 @@
-     (done?
-      (let (buf mem.buf)
+    (if done?
+      ;; Take ownership of the buffer directly rather than copying + caching.

@@ -40,0 +108,4 @@
+                      (start  :- :fixnum)
+                      (end    :- :fixnum)
+                      (need   :- :fixnum)
+                      (total  :- :fixnum))

@@ -241,3 +241,1 @@
-                       (fxior (fxarithmetic-shift-left (fxand byte1 #x0f) 12)
-                              (fxarithmetic-shift-left (fxand byte2 #x3f) 6)
-                              (fxand byte3 #x3f))))
+                       (fxior (fxarithmetic-shift-left (fxand byte1 #x07) 18)

@@ -62,3 +62,2 @@
 
-(defwriter-ext (write-delimited-string writer str)
-  (writer.write-delimited (cut &BufferedWriter-write-string <> str)
+(defwriter-ext (write-delimited-string-utf8 writer str)

@@ -22,0 +21,4 @@
+       (spawn/name 'echo-server-handler echo-server-handler cli)
+       (lp)))
+   (catch (e)
+     (unless (io-closed-error? e)

@@ -50,0 +53,4 @@
+         (DatagramSocket-sendto sock (unbox peer) buffer 0 read)
+         (lp))))
+   (catch (e)
+     (unless (io-closed-error? e)

@@ -77,0 +97,4 @@
+    ;; Detach restores any unread buffered content to the port.
+    (let (reader (open-input-port-buffered-reader i))
+      (unwind-protect (f reader)
+        (using (buf (interface-instance-object reader) : DetachableBuffer)

@@ -77,0 +105,4 @@
+   ((u8vector? i)
+    (let (reader (open-buffered-reader i))
+      (unwind-protect (f reader) (BufferedReader-close reader))))
+   ((or (eq? i #t) (eq? i 'stdin))

@@ -77,0 +126,4 @@
+      (unwind-protect (f writer) (BufferedWriter-flush writer))))
+   ((is-Writer? o)
+    (let (writer (open-buffered-writer o))
+      (unwind-protect (f writer) (BufferedWriter-flush writer))))

@@ -77,0 +139,4 @@
+    (let (writer (open-buffered-writer #f))
+      (f writer)
+      (get-memory-output-u8vector writer)))
+   ((or (eq? o 'stdout) (eq? o #t))

@@ -0,0 +223,4 @@
+
+(defstruct JSONRPCRequestHandler
+  ((processor : :procedure)
+   log)

@@ -0,0 +235,4 @@
+;; NB: This will catch any exception raised and convert it into an error notified to the client.
+;; TODO: have an optional parameter to specify a logging facility for those errors we find.
+(def (json-rpc-handler (req : Request) (res : ResponseHandler)
+                       (processor : :procedure) (log :? :procedure := #f))

@@ -0,0 +247,4 @@
+    ((POST) (json-rpc-handler/POST req res processor log)) ;; preferred method
+    ((GET) (json-rpc-handler/GET req res processor log)) ;; mostly for testing
+    (else
+     (when log (log [json-rpc-handler: 'BAD-HTTP-METHOD http-method]))

@@ -0,0 +283,4 @@
+       json
+       (catch (_)
+         (json-rpc-handler/response
+          req res log 'BAD-GET (hash ("jsonrpc" json-rpc-version) ("error" (parser-error))))

@@ -0,0 +326,4 @@
+      (try
+       (json->u8vector response-json)
+       (catch (_)
+         (when log (log [json-rpc-handler: request-json 'BAD-JSON-RESPONSE]))

@@ -0,0 +318,4 @@
+(def (json-rpc-handler/response
+      (req : Request)
+      (res : ResponseHandler)
+      log

@@ -0,0 +178,4 @@
+                    decimal-mark: (decimal-mark #\.)
+                    group-separator: (group-separator #f)
+                    exponent-allowed: (exponent-allowed #f))
+  (with-buffered-reader (reader)

@@ -0,0 +412,4 @@
+                    always-sign?: (always-sign? #f)
+                    decimal-mark: (decimal-mark #\.)
+                    precision-loss-behavior: (precision-loss-behavior 'error))
+  (with-buffered-writer (writer)

@@ -0,0 +31,4 @@
+;; An extensible vector containing the increasing sequence of all small enough primes
+;; NB: the initial 0 is so the useful array indices start with 1, keeping with convention.
+;; Note that this ExtensibleVector must contain all the primes already in the prime-sieve below.
+(def primes (list->ExtensibleVector '(0 2 3 5 7 11 13)))

@@ -0,0 +86,4 @@
+
+;; return true if the sieve found the number to be prime,
+;; false if the number was found to be composite,
+;; raise an error if the sieve wasn’t run far enough to tell

@@ -0,0 +27,4 @@
+    (if width (fxmax content width) content)))
+
+;; Write exact integer n in the given base to writer.
+;; base:        radix 2–36; lowercase letters for digits above 9 (unless upper-case?).

@@ -0,0 +35,4 @@
+;; pad:         ASCII fill char for width padding (default #\space; non-ASCII is an error).
+;;              #\0 with align: 'right puts sign before zeros, any other char puts pad before sign.
+;; align:       'right (default), 'left, or 'center.
+;; upper-case?: #t = use uppercase A–F for hex digits.

@@ -17,3 +16,1 @@
-   (to-string
-    (lambda (self)
-      (format "%a" self))))
+   (to-string object->string))

@@ -0,0 +108,4 @@
+
+(def (atomic-counter (initial-value : :fixnum := 0))
+  (let (v (vector initial-value))
+    (lambda ((increment : :fixnum := 1))

@@ -0,0 +16,4 @@
+(import
+  (for-syntax :std/number/misc)
+  :std/error
+  :std/io/api

@@ -0,0 +351,4 @@
+(defsyntax (defintprocs stx)
+  (def (make-def int size &int-ref &int-set!)
+    (with-syntax ((size size)
+                  (&int-ref/be      (stx-identifier &int-ref &int-ref "/be"))

@@ -433,2 +436,4 @@
 (def (call-with-getopt-parse gopt hash fun)
   (apply fun (getopt-parse->function-arguments gopt hash)))
+
+(def (call-with-processed-command-line processor command-line function)

@@ -435,0 +443,4 @@
+   ((list? processor)
+    (call-with-processed-command-line (apply getopt processor) command-line function))))
+
+(def (->getopt-spec spec)

@@ -13,0 +63,4 @@
+
+;; string keys, walist result
+(def (read-json-walist/string (reader : BufferedReader) (opt : JSONReadOptions))
+  (let* ((seen (make-hash-table size: 8))

@@ -13,0 +87,4 @@
+
+;; symbol keys, walist result
+(def (read-json-walist/symbol (reader : BufferedReader) (opt : JSONReadOptions))
+  (let* ((seen (make-hash-table test: eq?))

@@ -13,0 +111,4 @@
+
+;; symbol keys, hash-table result
+(def (read-json-hash/symbol (reader : BufferedReader) (opt : JSONReadOptions))
+  (let* ((obj (make-hash-table test: eq?))

@@ -13,0 +134,4 @@
+
+;; string keys, hash-table result
+(def (read-json-hash/string (reader : BufferedReader) (opt : JSONReadOptions))
+  (let* ((obj (make-hash-table size: 8))

@@ -0,0 +97,4 @@
+    (walist (map (match <> ([name . index] (cons name (##structure-ref x index type name))))
+                 (class-type-printable-slots type)))))
+
+(def (trivial-json->object strukt json (defaults_ #f))

@@ -0,0 +99,4 @@
+
+(def (trivial-json->object strukt json (defaults_ #f))
+  (def defaults (or defaults_ (hash)))
+  (def offsets (cast HashTable::interface (class-type-slot-table strukt)))

@@ -0,0 +110,4 @@
+       (else #f)))
+    (or (hash-get offsets slot)
+        (raise-bad-argument trivial-json->object "json key for struct" [key strukt json])))
+  (def object (make-object strukt n))

@@ -0,0 +136,4 @@
+    (raise-bad-argument trivial-json->object "unbound fields" [unbounds strukt json (hash->list defaults)]))
+  object)
+
+(defmethod {:json :object}

@@ -158,0 +209,4 @@
+      (write-json-vector/pretty writer obj ctx)
+      (write-json-vector writer obj ctx)))
+   ((hash-table? obj)
+    (let (lst (hash->list obj))

@@ -37,3 +38,3 @@
                 (fx+ start remaining)))
              (read (__bio-input-buffer-read delim.input output start end need)))
-        (set! delim.remaining (- remaining read))
+        (set! delim.remaining (fx- remaining read))

@@ -234,0 +608,4 @@
+  (OutputBuffer
+   (string-port-output-buffer
+    (drain!
+     (lambda (self buf whi)

@@ -560,3 +562,1 @@
-                ([]
-                 (finish (cons next chars) separators-count)))))
-          (finish chars separators-count))))))
+              (if (null? separators-rest)

@@ -0,0 +38,4 @@
+  :std/net/http/server/request
+  :std/net/http/server/status
+  (only-in :std/error raise-bad-argument deferror-class IOError Error raise/context)
+  (only-in :std/sync/atom atomic-counter)

@@ -0,0 +106,4 @@
+(def (atom-increment! atom (increment 1))
+  (swap! atom + increment))
+
+(def (atomic-counter (initial-value : :fixnum := 0))

@@ -0,0 +115,4 @@
+          (if (##fx= (##vector-cas! v 0 newval oldval) oldval)
+            oldval
+            (retry)))))
+    (case-lambda

@@ -89,1 +74,3 @@
-		            result))))
+		      (cons
+		       (with-syntax ((writer writer) (arg arg) (flags flags)
+			             (width width) (precision precision)

@@ -90,0 +82,4 @@
+	     (['float arg how flags width precision]
+	      (loop rest
+		    (cons (with-syntax ((writer writer) (arg arg) (flags flags)
+			                (width width) (precision precision)

@@ -560,3 +564,1 @@
-                ([]
-                 (finish (cons next chars) separators-count)))))
-          (finish chars separators-count))))))
+              (if (null? separators-rest)

@@ -0,0 +139,4 @@
+  (exact-integer? n))
+
+(definline (sint8? (n : :t)) => :boolean
+  (and (fixnum? n) (<= -128 n 127)))

@@ -0,0 +142,4 @@
+  (and (fixnum? n) (<= -128 n 127)))
+
+(definline (sint16? (n : :t)) => :boolean
+  (and (fixnum? n) (<= -32768 n 32767)))