diff --git a/Code/defs.lisp b/Code/defs.lisp index d4689f4914bcc139921d792ea4853d0e715ef054..b0638a1bfb032d71bd45437273e254be3bbcd1c7 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -85,7 +85,8 @@ #:do-set #:do-bag #:do-bag-pairs #:do-map #:do-map-domain #:do-seq #:do-tuple #:adjoinf #:removef #:includef #:excludef #:unionf #:intersectf #:set-differencef #:map-unionf #:map-intersectf #:imagef #:updatef #:composef - #:define-tuple-key #:def-tuple-key #:get-tuple-key #:tuple-key-name #:tuple-key? + #:define-tuple-key #:def-tuple-key #:get-tuple-key + #:tuple-key #:tuple-key-name #:tuple-key-type #:tuple-key? #:tuple-merge #:fset-setup-readtable #:*fset-readtable* #:fset-setup-rereading-readtable #:*fset-rereading-readtable* @@ -222,7 +223,7 @@ #:do-set #:do-bag #:do-bag-pairs #:do-map #:do-map-domain #:do-seq #:do-tuple #:adjoinf #:removef #:includef #:excludef #:unionf #:intersectf #:set-differencef #:map-unionf #:map-intersectf #:imagef #:updatef #:composef - #:define-tuple-key #:get-tuple-key #:tuple-key-name #:tuple-key? + #:define-tuple-key #:get-tuple-key #:tuple-key #:tuple-key-name #:tuple-key-type #:tuple-key? #:tuple-merge #:fset-setup-readtable #:*fset-readtable* #:fset-setup-rereading-readtable #:*fset-rereading-readtable* diff --git a/Code/jzon-defs.lisp b/Code/jzon-defs.lisp new file mode 100644 index 0000000000000000000000000000000000000000..6e6c0a9c1f6bfad4aafb59d716cf8d540b8f953b --- /dev/null +++ b/Code/jzon-defs.lisp @@ -0,0 +1,35 @@ +(in-package :cl-user) + +(defpackage :FSet/Jzon + (:use :cl :new-let) + (:shadowing-import-from :new-let #:let #:cond) + (:shadowing-import-from :fset2 #:set #:map) + (:import-from :fset #:gensymx) + (:import-from :fset2 + #:seq #:replay-map #:tuple #:push-last #:@ #:convert #:includef #:get-tuple-key + #:do-seq #:do-map #:do-tuple #:tuple-key #:tuple-key-name #:tuple-key-type #:char-seq?) + ;; Exports of names defined in this system + (:export #:json-element #:with-parser #:make-parser #:close-parser #:parse #:parse-top-level + #:coerced-fields #:coerce-tuple-key) + ;; We import and re-export (our guess at) the most commonly used parts of the Jzon API, + ;; mostly writer-related. + (:import-from :com.inuoe.jzon + #:span #:stringify #:json-atom + #:json-error #:json-limit-error #:json-parse-error #:json-parse-limit-error #:json-eof-error + #:json-write-error #:json-write-limit-error #:json-recursive-write-error + #:coerced-fields #:coerce-key + #:writer #:make-writer #:close-writer #:with-writer) + (:export #:span #:stringify #:json-atom + #:json-error #:json-limit-error #:json-parse-error #:json-parse-limit-error #:json-eof-error + #:json-write-error #:json-write-limit-error #:json-recursive-write-error + #:coerced-fields #:coerce-key + #:writer #:make-writer #:close-writer #:with-writer) + (:local-nicknames (#:jzon #:com.inuoe.jzon))) + +(defpackage :FSet/Jzon/Test + (:use :cl :new-let :fset/jzon) + (:shadowing-import-from :new-let #:let #:cond) + (:shadowing-import-from :fset2 #:set #:map) + (:import-from :fset2 + #:equal? #:seq #:replay-map #:tuple #:push-last #:@ #:includef #:define-tuple-key + #:do-seq #:do-map #:do-tuple #:tuple-key-name)) diff --git a/Code/jzon-tests.lisp b/Code/jzon-tests.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a0d6fcdf964fea87d06847c1d5a2fa8398f8bf8f --- /dev/null +++ b/Code/jzon-tests.lisp @@ -0,0 +1,49 @@ +(in-package :FSet/Jzon/Test) + +(define-tuple-key +json-color+ :type (or null string)) +(define-tuple-key +json-sizes+ :default (seq) :type seq) +(define-tuple-key +json-sizes-list+ :default '() :type list) +(define-tuple-key +json-visible?+ :default nil :type boolean) + +(defmethod coerce-tuple-key (key (pkg (eql :fset/jzon/test))) + (let ((str (symbol-name (tuple-key-name key)))) + ;; Strip leading "+JSON-" and trailing "+", and downcase + (string-downcase (subseq str 6 (1- (length str)))))) + +(defun test-fset/jzon () + (macrolet ((test (form) + `(unless ,form + (error "Test failed: ~S" ',form)))) + (test (equal? (parse "2") 2)) + (test (equal? (parse "[2]") (seq 2))) + (test (equal? (parse "[2, [7, 19, [42]]]") (seq 2 (seq 7 19 (seq 42))))) + (test (equal? (parse "[2, [7, 19, [42],]]" :allow-trailing-comma t) (seq 2 (seq 7 19 (seq 42))))) + (test (handler-case (progn (parse "[2, [7, 19, [42]]]" :max-depth 2) + nil) + (json-parse-limit-error () t))) + (test (equal? (parse "{\"foo\": 42}") (replay-map ("foo" 42)))) + (test (equal? (parse "{\"foo\": /* a comment */ 42}" :allow-comments t) (replay-map ("foo" 42)))) + (test (equal? (parse "{\"foo\": 42, \"bar\": 27}") (replay-map ("foo" 42) ("bar" 27)))) + (test (equal? (with-parser (p "{\"foo\": 42, \"bar\": 27}[3, 17]" :allow-multiple-content t) + (list (parse-top-level p) (parse-top-level p))) + (list (replay-map ("foo" 42) ("bar" 27)) (seq 3 17)))) + (test (equal? (parse "[\"gubbish\", {\"color\": \"blue\", \"sizes\": [4, 7, 11]}]") + (seq "gubbish" (replay-map ("color" "blue") ("sizes" (seq 4 7 11)))))) + (test (equal? (parse "[\"gubbish\", {\"color\": \"blue\", \"sizes\": [4, 7, 11]}]" :object-type 'map) + (seq "gubbish" (map ("color" "blue") ("sizes" (seq 4 7 11)))))) + (test (equal? (parse "[\"gubbish\", {\"color\": \"blue\", \"sizes\": [4, 7, 11]}]" + :object-type 'tuple :key-package :fset/jzon/test + :key-prefix '#:+json- :key-suffix #\+) + (seq "gubbish" (tuple (+json-color+ "blue") (+json-sizes+ (seq 4 7 11)))))) + + (test (equal? (stringify 2) "2")) + (test (equal? (stringify (seq 2)) "[2]")) + (test (equal? (stringify (seq 2 (seq 7 19 (seq 42)))) "[2,[7,19,[42]]]")) + (test (equal? (stringify (replay-map ("foo" 42) ("bar" 27))) "{\"foo\":42,\"bar\":27}")) + ;; We don't test on plain `map' because the ordering may be implementation-dependent, + ;; and it goes through the same code path as `replay-map' anyway. + (test (equal? (stringify (seq "gubbish" (replay-map ("color" "blue") ("sizes" (seq 4 7 11))))) + "[\"gubbish\",{\"color\":\"blue\",\"sizes\":[4,7,11]}]")) + (test (equal? (stringify (seq "gubbish" (tuple (+json-color+ nil) (+json-sizes-list+ nil) (+json-visible?+ nil)))) + "[\"gubbish\",{\"color\":null,\"sizes-list\":[],\"visible?\":false}]")) + "Passed.")) diff --git a/Code/jzon.lisp b/Code/jzon.lisp new file mode 100644 index 0000000000000000000000000000000000000000..8218b9351d52396a3d83167f3e473d23ddeee66d --- /dev/null +++ b/Code/jzon.lisp @@ -0,0 +1,272 @@ +(in-package :fset/jzon) + + +;;; Exported insted of `jzon:json-element'. +(deftype json-element () + '(or json-atom seq map tuple)) + + +;;; ================================================================================ +;;; Parsing + +(defstruct (parser + (:constructor raw-make-parser (jzon-parser allow-multiple-content max-depth object-type))) + jzon-parser + allow-multiple-content + max-depth + object-type) + +(defmacro with-parser ((var in &rest kwd-args + &key allow-comments allow-trailing-comma allow-multiple-content + max-string-length max-depth key-fn object-type + key-package key-case-mode key-prefix key-suffix) + &body body) + "Binds `var' around `body' to an FSet/Jzon parser that will read from `in', +which can be a vector, a stream, or a pathname. If `allow-comments' is true, +comments as in C \(`//' for single-line or `/* ... */' for block\) will be +accepted. If `allow-trailing-comma', a comma will be permitted after the last +element of an array or object. `max-string-length' limits the length of +strings, and `map-depth' the maximum nesting depth; these help protect against +DoS attacks. `key-fn' controls whether and how string pooling is done; the +default uses an FSet set. + +If `allow-multiple-content' is true, the input may contain multiple top-level +JSON values, which you can read by calling `parse-top-level' multiple times. + +JSON arrays are returned as FSet seqs; JSON objects are returned according to +`object-type', which can be `replay-map', `map', or `tuple'. If +`key-package' is supplied, keys will be interned in this package; this option +overrides `key-fn'. If `object-type' is `tuple', `key-package' is +required, and may not be the CL keyword package. If `key-package' is supplied: +\(a\) `key-case-mode' can be any of `:upcase', `:downcase', or `:preserve'; the +default is `:upcase'. \(b\) If supplied, `key-prefix' is prepended and +`key-suffix' is appended to the case-converted key before interning." + (declare (ignore allow-comments allow-trailing-comma allow-multiple-content + max-string-length max-depth key-fn object-type + key-package key-case-mode key-prefix key-suffix)) + `(let ((,var (make-parser ,in . ,kwd-args))) + (unwind-protect (progn . ,body) + (close-parser ,var)))) + +(defun make-parser (in &key allow-comments allow-trailing-comma allow-multiple-content + (max-string-length (min 1048576 (1- array-dimension-limit))) + (max-depth 128) (key-fn (make-fset-string-pool)) + (object-type 'replay-map) + key-package (key-case-mode ':upcase) (key-prefix "") (key-suffix "")) + "Constructs an FSet/Jzon parser that will read from `in', which can be a +vector, a stream, or a pathname. If `allow-comments' is true, comments as in +C \(`//' for single-line or `/* ... */' for block\) will be accepted. If +`allow-trailing-comma', a comma will be permitted after the last element of +an array or object. `max-string-length' limits the length of strings, and +`map-depth' the maximum nesting depth; these help protect against DoS attacks. +`key-fn' controls whether and how string pooling is done; the default uses +an FSet set. + +The returned parser should be closed after use; see `close-parser', and macro +`with-parser' which closes it automatically. + +If `allow-multiple-content' is true, the input may contain multiple top-level +JSON values, which you can read by calling `parse-top-level' multiple times. + +JSON arrays are returned as FSet seqs; JSON objects are returned according to +`object-type', which can be `replay-map', `map', or `tuple'. If +`key-package' is supplied, keys will be interned in this package; this option +overrides `key-fn'. If `object-type' is `tuple', `key-package' is +required, and may not be the CL keyword package. If `key-package' is supplied: +\(a\) `key-case-mode' can be any of `:upcase', `:downcase', or `:preserve'; the +default is `:upcase'. \(b\) If supplied, `key-prefix' is prepended and +`key-suffix' is appended to the case-converted key before interning." + (check-type max-depth (integer 1 65535)) + (check-type object-type (member replay-map map tuple)) + (check-type key-package (or null string symbol package)) + (check-type key-case-mode (member :upcase :downcase :preserve)) + (when (eq object-type 'tuple) + (when (null key-package) + (error "To use object-type `tuple', you must also supply a `key-package'")) + (unless (packagep key-package) + (setq key-package (uiop:find-package* key-package))) + (when (eq key-package (symbol-package ':upcase)) + ;; The problem is that keyword symbols are bound to themselves; we want to bind key names + ;; to their key objects. + (error "When object-type is `tuple', `key-package' may not be the keyword package"))) + (let ((key-prefix (string key-prefix)) + (key-suffix (string key-suffix)) + ((jzon-parser + (com.inuoe.jzon:make-parser in :allow-comments allow-comments :allow-trailing-comma allow-trailing-comma + :allow-multiple-content allow-multiple-content + :max-string-length max-string-length + :key-fn (if key-package + (lambda (s) + (declare (optimize (speed 3)) + (string s)) + (let ((s (ecase key-case-mode + (:upcase (string-upcase s)) + (:downcase (string-downcase s)) + (:preserve s))) + ((s (if (and (string= key-prefix "") + (string= key-suffix "")) + s + (concatenate 'string key-prefix s key-suffix))))) + (intern s key-package))) + key-fn))))) + (raw-make-parser jzon-parser allow-multiple-content max-depth object-type))) + +(defun close-parser (parser) + "Closes the parser. If the input was specified as a pathname, closes the +input stream." + (com.inuoe.jzon:close-parser (parser-jzon-parser parser))) + +(defun parse-top-level (parser) + "Reads one top-level JSON object from `parser'. If `parser' was created +with `allow-multiple-content' true, this can be called repeatedly; it will +return `nil' when there are no more top-level objects in the input." + (let ((ignore result (parse-value parser 0))) + (declare (ignore ignore)) + (unless (parser-allow-multiple-content parser) + (let ((event (com.inuoe.jzon:parse-next (parser-jzon-parser parser)))) + (when event + (error "Unexpected text following the top-level value")))) + result)) + +(defun parse (in &key allow-comments allow-trailing-comma + (max-string-length (min 1048576 (1- array-dimension-limit))) + (max-depth 128) (key-fn (make-fset-string-pool)) + (object-type 'replay-map) + key-package (key-case-mode ':upcase) (key-prefix "") (key-suffix "")) + "Constructs an FSet/Jzon parser that will read from `in', which can be a +vector, a stream, or a pathname, and reads one top-level object from it. +If `allow-comments' is true, comments as in C \(`//' for single-line or +`/* ... */' for block\) will be accepted. If `allow-trailing-comma', a +comma will be permitted after the last element of an array or object. +`max-string-length' limits the length of strings, and `map-depth' the maximum +nesting depth; these help protect against DoS attacks. `key-fn' controls +whether and how string pooling is done; the default uses an FSet set. + +JSON arrays are returned as FSet seqs; JSON objects are returned according to +`object-type', which can be `replay-map', `map', or `tuple'. If +`key-package' is supplied, keys will be interned in this package; this option +overrides `key-fn'. If `object-type' is `tuple', `key-package' is +required, and may not be the CL keyword package. If `key-package' is supplied: +\(a\) `key-case-mode' can be any of `:upcase', `:downcase', or `:preserve'; the +default is `:preserve'. \(b\) If supplied, `key-prefix' is prepended and +`key-suffix' is appended to the case-converted key before interning." + (with-parser (parser in :allow-comments allow-comments :allow-trailing-comma allow-trailing-comma + :max-string-length max-string-length :max-depth max-depth :key-fn key-fn + :object-type object-type + :key-package key-package :key-case-mode key-case-mode + :key-prefix key-prefix :key-suffix key-suffix) + (parse-top-level parser))) + +(defun parse-value (parser depth) + (declare (optimize (debug 3)) + (fixnum depth)) + (flet ((check-depth () + (when (= depth (parser-max-depth parser)) + (signal-parse-error parser 'json-parse-limit-error (parser-max-depth parser) + "Maximum depth exceeded.")))) + (let ((event value (com.inuoe.jzon:parse-next (parser-jzon-parser parser)))) + (ecase event + (:value (values event value)) + ((nil) (values nil nil)) + (:begin-array + (check-depth) + (let ((result (seq))) + (loop + (let ((ev val (parse-value parser (1+ depth)))) + (when (eq ev ':end-array) + (return (values ':value result))) + (push-last result val))))) + (:begin-object + (check-depth) + (let ((result (ecase (parser-object-type parser) + (replay-map (replay-map)) + (map (map)) + (tuple (tuple))))) + (loop + (let ((kev kval (com.inuoe.jzon:parse-next (parser-jzon-parser parser)))) + (when (eq kev ':end-object) + (return (values ':value result))) + (unless (eq kev ':object-key) + (error "Syntax error: expected object key; found ~S ~S" kev kval)) + (let ((ev val (parse-value parser (1+ depth))) + ((kval (if (eq (parser-object-type parser) 'tuple) + (if (boundp kval) (symbol-value kval) + (get-tuple-key kval)) + kval)))) + (unless (eq ev ':value) + (error "Internal error: expected value; found ~S ~S" ev val)) + (setf (@ result kval) val)))))) + ((:end-array :end-object) + event))))) + +(defun signal-parse-error (parser error-class limit format &rest args) + ;; Depends on Jzon internals. + (let ((line column (funcall (slot-value (parser-jzon-parser parser) 'com.inuoe.jzon::%pos)))) + (error error-class :format-control format :format-arguments args + :line line :column column :limit limit))) + +(defun make-fset-string-pool () + (let ((pool (set))) + (lambda (k) + (let ((present? prev-k (@ pool k))) + (if present? prev-k + (progn + (includef pool k) + k)))))) + +;;; ================================================================================ +;;; Writing + +;;; We just re-export the main Jzon writing operations; the methods below handle +;;; writing the FSet types. + +(defmethod coerce-key ((key seq)) + (convert 'string key)) + +(defgeneric coerce-tuple-key (key key-name-package-as-keyword) + (:documentation + "Generic function called to turn a `tuple-key' into a string. The first +argument is the key; the second is the key's name's package name, as a +keyword symbol. So you can write methods like + + (defmethod coerce-tuple-key (key (pkg (eql :my-package))) + ...)") + (:method (key pkg) + "The default method returns the key's name in lowercase." + (declare (ignore pkg)) + (string-downcase (tuple-key-name key)))) + +(defmethod coerce-key ((key tuple-key)) + (coerce-tuple-key key (intern (package-name (symbol-package (tuple-key-name key))) + (symbol-package ':foo)))) + +(defmethod coerce-tuple-key (key pkg-name) + (declare (ignore pkg-name)) + (symbol-name (tuple-key-name key))) + +(defmethod com.inuoe.jzon:write-value ((writer writer) (s seq)) + (com.inuoe.jzon:with-array writer + (do-seq (x s) + (com.inuoe.jzon:write-value writer x)))) + +(defmethod com.inuoe.jzon:write-value ((writer writer) (m map)) + (com.inuoe.jzon:with-object writer + (do-map (k v m) + ;; Looks like `write-property' was intended to be exported. + (com.inuoe.jzon::write-property writer k v)))) + +(defmethod com.inuoe.jzon:write-value ((writer writer) (tup tuple)) + (com.inuoe.jzon:with-object writer + (do-tuple (k v tup) + ;; Jzon will downcase the key, unless it is in mixed case already; there's no option + ;; to override this behavior. + (let ((type (tuple-key-type k)) + ;; Jzon lets you further customize this behavior by specializing `coerced-fields'. + ;; A similar feature could be added here. + ((v (or v (cond ((and (subtypep 'boolean type) (subtypep type 'boolean)) + nil) + ((and (subtypep 'list type) (subtypep type 'list)) + (seq)) + (t 'null)))))) + (com.inuoe.jzon::write-property writer k v))))) + diff --git a/Code/macros.lisp b/Code/macros.lisp index 40a4a39fd81c1b38b6be17d2bf18a264f157cfa0..298000220e1fe4ac3bbf72632d77f25b878b6e2f 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -1343,7 +1343,9 @@ (define-setf-expander fset2:@ (collection key &environment env) `((convert 'list ,tuple) #'null (:values 2 #'(lambda (al) (values (caar al) (cdar al)))) - #'cdr)) + #'cdr + nil nil + (do-tuple ,tuple))) (gmap:def-gmap-res-type tuple (&key filterp) `((empty-dyn-tuple) (:consume 2 #'Tuple-With) nil ,filterp)) diff --git a/Code/tuples.lisp b/Code/tuples.lisp index 3b31715e231bb02a1f516811b11223907bcf0f51..fb8534d2e6e82d8ce2ad6835cc75529a64e0b631 100644 --- a/Code/tuples.lisp +++ b/Code/tuples.lisp @@ -102,7 +102,7 @@ (defstruct (dyn-tuple (:include tuple) - (:constructor make-dyn-tuple (descriptor contents &optional hash-value)) + (:constructor make-dyn-tuple (descriptor contents hash-value)) (:predicate dyn-tuple?) (:print-function print-dyn-tuple) (:copier nil)) @@ -117,14 +117,15 @@ (defstruct (dyn-tuple (defstruct (tuple-key - (:constructor make-tuple-key (name default number)) + (:constructor make-tuple-key (name default number &optional type)) (:predicate tuple-key?) (:print-function print-tuple-key)) (name nil :read-only t) ; a symbol (normally, but actually can be any type known to FSet) (default 'no-default) ; default, if any, for tuples with no explicit entry for this key ; (in FSet1, this was a function called on the tuple) (number nil :type fixnum - :read-only t)) ; used for lookup and sorting + :read-only t) ; used for lookup and sorting + (type t)) (deflex +Tuple-Key-Name-Map+ (empty-ch-map)) @@ -132,6 +133,13 @@ (defstruct (tuple-key (deflex +Tuple-Key-Lock+ (make-lock "Tuple Key Lock")) +(define-condition tuple-default-type-error (type-error) + ((key-name :initarg :key-name :reader tuple-default-type-error-key-name)) + (:report (lambda (err stream) + (format stream "The value~% ~S~%is not of type~% ~S~%when setting default for tuple key ~S" + (type-error-datum err) (type-error-expected-type err) + (tuple-default-type-error-key-name err))))) + (defun get-tuple-key (name &optional default) "Finds or creates a tuple key named `name'. If `default' is supplied and nonnull, it will be returned from `lookup' when the tuple has no explicit pair @@ -154,7 +162,7 @@ (defstruct (tuple-key (push-last +Tuple-Key-Seq+ key) key) (error "Tuple key space exhausted"))))))) -(defun fset2:get-tuple-key (name &key (default nil default?) no-default?) +(defun fset2:get-tuple-key (name &key (type 't) (default nil default?) no-default?) "Finds or creates a tuple key named `name'. If `default' is supplied, sets the key's default to it; this value will be returned from `lookup' when the tuple has no explicit pair with this key. If `no-default?' is true, clears the @@ -163,6 +171,8 @@ (defstruct (tuple-key of `nil'; if it already existed, its default will be unchanged." (when (and default? no-default?) (error "Both a default and `no-default?' specified")) + (unless (or no-default? (eq type 't) (typep default type)) + (error 'tuple-default-type-error :datum default :expected-type type :key-name name)) (with-lock (+Tuple-Key-Lock+) (let ((key (lookup +Tuple-Key-Name-Map+ name)) (key-idx (size +Tuple-Key-Seq+))) @@ -171,10 +181,11 @@ (defstruct (tuple-key (setf (tuple-key-default key) default)) (no-default? (setf (tuple-key-default key) 'no-default))) + (setf (tuple-key-type key) type) key) ((<= key-idx Tuple-Key-Number-Mask) (let ((key (make-tuple-key name (if default? default (and no-default? 'no-default)) - key-idx))) + key-idx type))) (setf (lookup +Tuple-Key-Name-Map+ name) key) (push-last +Tuple-Key-Seq+ key) key)) @@ -198,7 +209,7 @@ (defstruct (tuple-key (assert (symbolp name)) `(deflex ,name (get-tuple-key ',name ,default) . ,(and doc-string `(,doc-string)))) -(defmacro fset2:define-tuple-key (name &key (default nil default?) no-default? documentation) +(defmacro fset2:define-tuple-key (name &key (type 't) (default nil default?) no-default? documentation) "Defines a tuple key named `name' as a global lexical variable (see `deflex'). If `default' is supplied, it will be returned from `lookup', instead of `nil', when the tuple has no explicit pair with this key. @@ -207,13 +218,14 @@ (defstruct (tuple-key (assert (symbolp name)) (when (and default? no-default?) (error "Both a default and `no-default?' specified")) - `(deflex-reinit ,name (fset2:get-tuple-key ',name ,@(if default? `(:default ,default) - (and no-default? '(:no-default? t)))) + `(deflex-reinit ,name (fset2:get-tuple-key ',name :type ',type + ,@(if default? `(:default ,default) + (and no-default? '(:no-default? t)))) . ,(and documentation `(,documentation)))) (defun print-tuple-key (key stream level) (declare (ignore level)) - (format stream "#" (tuple-key-name key))) + (format stream "#" (tuple-key-name key))) (declaim (inline key-compare)) (defun key-compare (key1 key2) @@ -292,7 +304,7 @@ (defmethod hash-value ((td Tuple-Desc)) (define-hash-function tuple-desc-compare tuple-desc-hash-value) -;;; Urgh, Allegro 6 doesn't obey inline declarations, so we use a macro for this. +;;; Urgh, Allegro doesn't obey inline declarations, so we use a macro for this. ;;; This takes its argument doubled for the convenience of the common case (lookup). ;;; &&& These numbers are SWAGs and may be too small. See `Tuple-Reorder-Keys'. (defmacro Tuple-Window-Size (nkeys*2) @@ -320,7 +332,7 @@ (defmethod domain ((tup dyn-tuple)) (unless desc (setq desc (Make-Tuple-Desc (empty-ch-set) (vector))) (setf (lookup +Tuple-Descriptor-Map+ (empty-ch-set)) desc)) - (make-dyn-tuple desc (vector)))) + (make-dyn-tuple desc (vector) nil))) (deflex +Tuple-Random-Value+ 0 "State for an extremely fast, low-quality generator of small numbers of @@ -403,11 +415,20 @@ (defmethod domain ((tup dyn-tuple)) (setf (svref pairs idx) to-key-pr) (setf (svref pairs to-idx) key-pr)))))) +(define-condition tuple-value-type-error (type-error) + ((key :initarg :key :reader tuple-value-type-error-key)) + (:report (lambda (err stream) + (format stream "The value~% ~S~%is not of type~% ~S~%when assigning tuple key ~S" + (type-error-datum err) (type-error-expected-type err) + (tuple-value-type-error-key err))))) ;;; Someday: multiple key/value pair update. (defun Tuple-With (tuple key val) - (declare (optimize (speed 3) (safety 0))) + (let ((type (tuple-key-type key))) + (unless (or (eq type 't) (typep val type)) + (error 'tuple-value-type-error :datum val :expected-type type :key key))) (let ((old-val? old-val (Tuple-Lookup tuple key))) + (declare (optimize (speed 3) (safety 0))) ; moved here to quiet note on `(typep val type)' (if old-val? (if (equal? val old-val) tuple @@ -442,7 +463,7 @@ (defmethod domain ((tup dyn-tuple)) (hash-unmix (hash-value-fixnum val) (hash-value-fixnum prev-val)))))))) (setf (svref new-chunk val-idx) val) - (if single-chunk? (make-dyn-tuple desc new-chunk) + (if single-chunk? (make-dyn-tuple desc new-chunk new-hash) (progn (dotimes (i (length contents)) (setf (svref new-contents i) (svref contents i))) diff --git a/fset.asd b/fset.asd index e0290b6e2f35b3727dcbfc8597cb5686e2b974a2..a88071ddc6acad1f6006d3094dd2c9915663ac30 100644 --- a/fset.asd +++ b/fset.asd @@ -13,7 +13,7 @@ See: https://gitlab.common-lisp.net/fset/fset/-/wikis/home " :author "Scott L. Burson " - :version "2.1.3" + :version "2.2.0" :homepage "https://gitlab.common-lisp.net/fset/fset/-/wikis/home" :source-control "https://github.com/slburson/fset" :license "BSD-2-Clause" @@ -74,3 +74,24 @@ See: https://gitlab.common-lisp.net/fset/fset/-/wikis/home :components ((:module "Code" :serial t :components ((:file "iterate-tests"))))) + +(defsystem :FSet/Jzon + :description "FSet definitions for the Jzon JSON reader/writer." + :author "Scott L. Burson " + :homepage "https://gitlab.common-lisp.net/fset/fset/-/wikis/home" + :source-control "https://github.com/slburson/fset" + :license "BSD-2-Clause" + :depends-on ("fset" "com.inuoe.jzon") + :in-order-to ((test-op (test-op "fset/jzon/test"))) + :components ((:module "Code" + :serial t + :components ((:file "jzon-defs") + (:file "jzon"))))) + +(defsystem :FSet/Jzon/test + :description "Test system for FSet/Iterate" + :depends-on (:fset/jzon) + :perform (test-op (o c) (symbol-call :fset/jzon/test :test-fset/jzon)) + :components ((:module "Code" + :serial t + :components ((:file "jzon-tests")))))