From 6ffa4af47bc5529494e821c8ea3736b9b4477ebd Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Thu, 25 Jul 2024 08:54:37 -0400 Subject: [PATCH 01/16] quaviver: preserve nan sign --- code/float-internal-integer-form.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/code/float-internal-integer-form.lisp b/code/float-internal-integer-form.lisp index dffd5ce0..4ad3f5d1 100644 --- a/code/float-internal-integer-form.lisp +++ b/code/float-internal-integer-form.lisp @@ -33,7 +33,7 @@ (if (ldb-test ,nan-type-byte-form bits) :quiet-nan :signaling-nan) - 1) + sign) (values 0 :infinity sign))) (t (let ((significand (ldb ,significand-byte-form bits))) From da57a1abe785c5fdbaa092876dfd219a88d4e898 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Thu, 25 Jul 2024 05:57:20 -0400 Subject: [PATCH 02/16] math: add count-digits --- code/math/count-digits.lisp | 59 +++++++++++++++++++++++++++++++++++++ code/math/log-expt.lisp | 27 +++++++++++++++++ code/math/utility.lisp | 10 +++++++ code/packages.lisp | 3 +- quaviver.asd | 1 + 5 files changed, 99 insertions(+), 1 deletion(-) create mode 100644 code/math/count-digits.lisp diff --git a/code/math/count-digits.lisp b/code/math/count-digits.lisp new file mode 100644 index 00000000..e666bc48 --- /dev/null +++ b/code/math/count-digits.lisp @@ -0,0 +1,59 @@ +(in-package #:quaviver.math) + +(declaim (ftype (function ((integer 2 36) unsigned-byte) (unsigned-byte 22)) + count-digits) + (inline count-digits)) + +(defvar *count-digits-table* + (compute-count-digits +min-base+ +max-base+ + (quaviver:arithmetic-size #+quaviver/long-float + 'long-float + #-quaviver/long-float + 'double-float))) + +(defun count-digits (base value) + (declare (optimize speed)) + (let ((len (integer-length value))) + (cond ((zerop len) + 1) + ((eql base 2) + len) + ((= (logcount base) 1) + (values (ceiling len + (1- (integer-length base))))) + (t + (multiple-value-bind (count farp) + (ceiling-log-expt/far base 2 (1- len)) + (if (or farp + (< value + (let ((table (svref *count-digits-table* (- base +min-base+)))) + (if (< count (length table)) + (svref table count) + (cl:expt base count))))) + count + (1+ count))))))) + +(define-compiler-macro count-digits (&whole whole base value) + (cond ((not (constantp base)) + whole) + ((eql base 2) + `(integer-length ,value)) + ((= (logcount base) 1) + `(values (ceiling (integer-length ,value) + ,(1- (integer-length base))))) + (t + (let ((table (svref *count-digits-table* (- base +min-base+)))) + `(let* ((value ,value) + (len (integer-length value))) + (declare (optimize speed)) + (if (zerop len) + 1 + (multiple-value-bind (count farp) + (ceiling-log-expt/far ,base 2 (1- len)) + (declare (type quaviver:exponent-word count)) + (if (or farp + (if (< count ,(length table)) + (< value (svref ,table count)) + (< value (cl:expt ,base count)))) + count + (1+ count))))))))) diff --git a/code/math/log-expt.lisp b/code/math/log-expt.lisp index 00728366..cd8908b7 100644 --- a/code/math/log-expt.lisp +++ b/code/math/log-expt.lisp @@ -106,3 +106,30 @@ ,offset 0)) ,divisor))))))) + +(defun ceiling-log-expt/far (log-base expt-base exp) + (let ((multiplier (the (unsigned-byte 25) + (aref *log-expt* + (- log-base +min-base+) + (- expt-base +min-base+))))) + (multiple-value-bind (q r) + (ceiling (* exp multiplier) + (ash 1 +log-expt-shift+)) + (values q + (< r (- multiplier)))))) + +(define-compiler-macro ceiling-log-expt/far + (&whole whole log-base expt-base exp) + (if (or (not (constantp log-base)) + (not (constantp expt-base))) + whole + (let ((multiplier (aref *log-expt* + (- log-base +min-base+) + (- expt-base +min-base+))) + (divisor (ash 1 +log-expt-shift+))) + `(multiple-value-bind (q r) + (ceiling (* ,exp ,multiplier) + ,divisor) + (declare (optimize speed)) + (values q + (< r ,(- multiplier))))))) diff --git a/code/math/utility.lisp b/code/math/utility.lisp index 92e99c1a..9bac6a66 100644 --- a/code/math/utility.lisp +++ b/code/math/utility.lisp @@ -47,3 +47,13 @@ do (setf (getf tables arithmetic-size) (max (getf tables arithmetic-size 0) bound)))) + +(defun compute-count-digits (min-base max-base width) + (make-array (- max-base min-base -1) + :initial-contents + (loop for base from min-base upto max-base + for max-power = (floor (log (ash 1 (1- width)) base)) + collect (make-array (1+ max-power) + :initial-contents + (loop for power from 0 upto max-power + collect (cl:expt base power)))))) diff --git a/code/packages.lisp b/code/packages.lisp index 75f3b49d..3679dfb4 100644 --- a/code/packages.lisp +++ b/code/packages.lisp @@ -62,7 +62,8 @@ #:floor-multiply/64-128q128 #:floor-multiply/evenp/64-128q128 #:floor-log-expt - #:ceiling-log-expt)) + #:ceiling-log-expt + #:count-digits)) #+sbcl (pushnew :quaviver.math/smallnum *features*) diff --git a/quaviver.asd b/quaviver.asd index 4a34ddc7..9bbfb7d7 100644 --- a/quaviver.asd +++ b/quaviver.asd @@ -26,6 +26,7 @@ :serial t :components ((:file "log-expt") (:file "utility") + (:file "count-digits") (:file "implementation") (:file "expt") (:file "round-to-odd"))) From 98b4b65dc01312abae60f5497a6959f74a5e8292 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Mon, 22 Jul 2024 10:15:11 -0400 Subject: [PATCH 03/16] quaviver, native: refactor write/parse/compose interface --- code/compose-digits.lisp | 67 +++++++++ code/digits-integer.lisp | 44 ------ code/integer-digits.lisp | 255 --------------------------------- code/interface.lisp | 8 +- code/native/float-integer.lisp | 15 +- code/packages.lisp | 9 +- code/parse-digits.lisp | 33 +++++ code/read-digits.lisp | 38 +++++ code/write-digits.lisp | 220 ++++++++++++++++++++++++++++ quaviver.asd | 9 +- 10 files changed, 384 insertions(+), 314 deletions(-) create mode 100644 code/compose-digits.lisp delete mode 100644 code/digits-integer.lisp delete mode 100644 code/integer-digits.lisp create mode 100644 code/parse-digits.lisp create mode 100644 code/read-digits.lisp create mode 100644 code/write-digits.lisp diff --git a/code/compose-digits.lisp b/code/compose-digits.lisp new file mode 100644 index 00000000..19b30743 --- /dev/null +++ b/code/compose-digits.lisp @@ -0,0 +1,67 @@ +;;;; SPDX-FileCopyrightText: Copyright (c) 2024 s-expressionists +;;;; SPDX-License-Identifier: MIT +;;;; + +(in-package #:quaviver) + +(defun %compose-digits/vector (base value) + (declare (optimize speed)) + (if (zerop value) + #(0) + (loop with digits = (make-array (quaviver.math:count-digits base value)) + with digit + for i from (1- (length digits)) downto 0 + finally (return digits) + do (multiple-value-setq (value digit) + (floor value 10)) + (setf (aref digits i) digit)))) + +(defun %compose-digits/base-string (base value) + (declare (optimize speed)) + (if (zerop value) + #(0) + (loop with digits = (make-string (quaviver.math:count-digits base value) + :element-type 'base-char) + with digit + for i from (1- (length digits)) downto 0 + finally (return digits) + do (multiple-value-setq (value digit) + (floor value 10)) + (setf (aref digits i) (digit-char digit))))) + +(defun %compose-digits/string (base value) + (declare (optimize speed)) + (if (zerop value) + #(0) + (loop with digits = (make-string (quaviver.math:count-digits base value) + :element-type 'character) + with digit + for i from (1- (length digits)) downto 0 + finally (return digits) + do (multiple-value-setq (value digit) + (floor value 10)) + (setf (aref digits i) (digit-char digit))))) + +(defun %compose-digits/list (base value) + (declare (optimize speed)) + (if (zerop value) + (list 0) + (prog (digits digit) + next + (unless (zerop value) + (multiple-value-setq (value digit) (floor value base)) + (push digit digits) + (go next)) + (return digits)))) + +(defmethod compose-digits (result-type base value) + (cond ((subtypep result-type 'base-string) + (%compose-digits/base-string base value)) + ((subtypep result-type 'string) + (%compose-digits/string base value)) + ((subtypep result-type 'vector) + (%compose-digits/vector base value)) + ((subtypep result-type 'list) + (%compose-digits/list base value)) + (t + (error "Unable to compose digits for type ~a" result-type)))) diff --git a/code/digits-integer.lisp b/code/digits-integer.lisp deleted file mode 100644 index 36da4d22..00000000 --- a/code/digits-integer.lisp +++ /dev/null @@ -1,44 +0,0 @@ -(in-package #:quaviver) - -(defmethod digits-integer (client base (digits vector)) - (declare (ignore client)) - (loop with result = 0 - for digit across digits - finally (return result) - do (setf result (+ (* result base) digit)))) - -(defmethod digits-integer (client (base (eql 2)) (digits vector)) - (declare (ignore client)) - (loop with result = 0 - for digit across digits - finally (return result) - do (setf result (logior (ash result 1) digit)))) - -(defmethod digits-integer (client base (digits string)) - (declare (ignore client)) - (loop with result = 0 - for digit across digits - finally (return result) - do (setf result (+ (* result base) (digit-char-p digit base))))) - -(defmethod digits-integer (client (base (eql 2)) (digits string)) - (declare (ignore client)) - (loop with result = 0 - for digit across digits - finally (return result) - do (setf result (logior (ash result 1) - (if (eql digit #\1) 1 0))))) - -(defmethod digits-integer (client base (digits list)) - (declare (ignore client)) - (loop with result = 0 - for digit in digits - finally (return result) - do (setf result (+ (* result base) digit)))) - -(defmethod digits-integer (client (base (eql 2)) (digits list)) - (declare (ignore client)) - (loop with result = 0 - for digit in digits - finally (return result) - do (setf result (logior (ash result 1) digit)))) diff --git a/code/integer-digits.lisp b/code/integer-digits.lisp deleted file mode 100644 index 635b8e80..00000000 --- a/code/integer-digits.lisp +++ /dev/null @@ -1,255 +0,0 @@ -;;;; SPDX-FileCopyrightText: Copyright (c) 2024 s-expressionists -;;;; SPDX-License-Identifier: MIT -;;;; -;;;; This file contains code ported from Daniel Lemire's blog [1], which -;;;; he has dedicated to the public domain. -;;;; This file also contains code ported from itoa-benchmark [2], which -;;;; at the time of the port was copyright 2014-2016 Milo Yip and -;;;; licensed under the MIT license (Expat). -;;;; -;;;; Any original code herein is licensed under the MIT license (Expat). -;;;; -;;;; [1]: https://github.com/lemire/Code-used-on-Daniel-Lemire-s-blog/blob/693681a91167b0b694294bea35f5716c2d2ee264/2021/06/03 -;;;; [2]: https://github.com/miloyip/itoa-benchmark - -(in-package #:quaviver) - -;;; Counting digits -;;; -;;; The digit-counting algorithms implemented here — basically faster -;;; versions of (CEILING (LOG INTEGER 10)) — include a port of Daniel -;;; Lemire's code [1,2] (which gives credit to Kendall Willets), and -;;; also a port of part of itoa-benchmark [3]. -;;; An accompanying description of Daniel Lemire's algorithm is also -;;; available [4]. -;;; -;;; The algorithms consist of computing the integer base-2 and base-10 -;;; logarithms separately and then dividing them. -;;; The base-2 logarithm can be optimized to -;;; (1- (INTEGER-LENGTH INTEGER)) and the base-10 logarithm with lookup -;;; tables. -;;; -;;; Both COUNT-DIGITS/32 and COUNT-DIGITS/64 fail when given 0, but that -;;; is immaterial because the 0 value is handled specially in -;;; DIGIT-VECTOR/32 and DIGIT-VECTOR/64. -;;; -;;; [1]: https://github.com/lemire/Code-used-on-Daniel-Lemire-s-blog/blob/693681a91167b0b694294bea35f5716c2d2ee264/2021/06/03/digitcount.c -;;; [2]: https://github.com/lemire/Code-used-on-Daniel-Lemire-s-blog/blob/693681a91167b0b694294bea35f5716c2d2ee264/2021/06/03/generate.py -;;; [3]: https://github.com/miloyip/itoa-benchmark/blob/6b66399db63358157892c258a2daa75c07173b05/src/tmueller.cpp -;;; [4]: https://lemire.me/blog/2021/06/03/computing-the-number-of-digits-of-an-integer-even-faster/ - -;;; Based on https://github.com/lemire/Code-used-on-Daniel-Lemire-s-blog/blob/693681a91167b0b694294bea35f5716c2d2ee264/2021/06/03/generate.py#L9-L17 -(defun compute-count-digits/32-table () - (loop with result = (make-array 32) - for i from 1 upto 32 - do (let ((log10 (ceiling (log (ash 1 (1- i)) 10)))) - (setf (aref result (1- i)) - (if (< i 31) - (+ #.(ash 1 32) (- (expt 10 log10)) (ash log10 32)) - (ash log10 32)))) - finally (return result))) - -;;; Based on https://github.com/lemire/Code-used-on-Daniel-Lemire-s-blog/blob/693681a91167b0b694294bea35f5716c2d2ee264/2021/06/03/digitcount.c#L40-L50 -(defun count-digits/32 (integer) - (declare (optimize speed) - ((unsigned-byte 32) integer)) - (ash (+ integer - (svref #(4294967295 8589934582 8589934582 8589934582 12884901788 12884901788 - 12884901788 17179868184 17179868184 17179868184 21474826480 21474826480 - 21474826480 21474826480 25769703776 25769703776 25769703776 30063771072 - 30063771072 30063771072 34349738368 34349738368 34349738368 34349738368 - 38554705664 38554705664 38554705664 41949672960 41949672960 41949672960 - 42949672960 42949672960) - (1- (integer-length integer)))) - -32)) - -;;; Based on https://github.com/miloyip/itoa-benchmark/blob/6b66399db63358157892c258a2daa75c07173b05/src/tmueller.cpp#L108-L113 -(defun count-digits/64 (integer) - (declare (optimize speed) - ((unsigned-byte 64) integer)) - (let ((n (ash (* 1233 (integer-length integer)) -12))) - (when (>= integer (svref #(1 - 10 - 100 - 1000 - 10000 - 100000 - 1000000 - 10000000 - 100000000 - 1000000000 - 10000000000 - 100000000000 - 1000000000000 - 10000000000000 - 100000000000000 - 1000000000000000 - 10000000000000000 - 100000000000000000 - 1000000000000000000 - 10000000000000000000) - n)) - (incf n)) - n)) - -(defun count-digits/128 (integer) - (declare (optimize speed) - ((unsigned-byte 128) integer)) - (let ((n (ash (* 1233 (integer-length integer)) -12))) - (when (>= integer (svref #(1 - 10 - 100 - 1000 - 10000 - 100000 - 1000000 - 10000000 - 100000000 - 1000000000 - 10000000000 - 100000000000 - 1000000000000 - 10000000000000 - 100000000000000 - 1000000000000000 - 10000000000000000 - 100000000000000000 - 1000000000000000000 - 10000000000000000000 - 100000000000000000000 - 1000000000000000000000 - 10000000000000000000000 - 100000000000000000000000 - 1000000000000000000000000 - 10000000000000000000000000 - 100000000000000000000000000 - 1000000000000000000000000000 - 10000000000000000000000000000 - 100000000000000000000000000000 - 1000000000000000000000000000000 - 10000000000000000000000000000000 - 100000000000000000000000000000000 - 1000000000000000000000000000000000 - 10000000000000000000000000000000000 - 100000000000000000000000000000000000 - 1000000000000000000000000000000000000 - 10000000000000000000000000000000000000 - 100000000000000000000000000000000000000 - 1000000000000000000000000000000000000000 - 10000000000000000000000000000000000000000 - 100000000000000000000000000000000000000000) - n)) - (incf n)) - n)) - -(defun digit-vector/32 (value) - ;; The division by 10 could be optimized by reinterpreting the - ;; value in fixed point arithmetic with the decimal point to - ;; the left of the leading digit and multiplying by 10 at each - ;; iteration instead [1,2]. - ;; - ;; [1]: https://lemire.me/blog/2021/05/17/converting-binary-integers-to-ascii-characters-apple-m1-vs-amd-zen2/#comment-584345 - ;; [2]: https://stackoverflow.com/questions/7890194/optimized-itoa-function/32818030#32818030 - (loop with digits = (make-array (count-digits/32 value)) - with digit - for i from (1- (length digits)) downto 0 - do (multiple-value-setq (value digit) (floor value 10)) - (setf (aref digits i) digit) - finally (return digits))) - -(defun digit-vector/64 (value) - (declare (optimize speed) - (type (unsigned-byte 64) value)) - (loop with digits = (make-array (count-digits/64 value)) - with digit - for i from (1- (length digits)) downto 0 - finally (return digits) - do (multiple-value-setq (value digit) (floor value 10)) - (setf (aref digits i) digit))) - -(defun digit-vector/128 (value) - (declare (optimize speed) - (type (unsigned-byte 128) value)) - (loop with digits = (make-array (count-digits/128 value)) - with digit - for i from (1- (length digits)) downto 0 - finally (return digits) - do (multiple-value-setq (value digit) (floor value 10)) - (setf (aref digits i) digit))) - -(defmethod quaviver:integer-digits - (client (result-type (eql 'vector)) (base (eql 10)) value) - (declare (ignore client)) - (if (zerop value) - #(0) - (etypecase value - ((unsigned-byte 32) - (digit-vector/32 value)) - ((unsigned-byte 64) - (digit-vector/64 value)) - ((unsigned-byte 128) - (digit-vector/128 value))))) - -(defun digit-string/32 (value) - ;; The division by 10 could be optimized by reinterpreting the - ;; value in fixed point arithmetic with the decimal point to - ;; the left of the leading digit and multiplying by 10 at each - ;; iteration instead [1,2]. - ;; - ;; [1]: https://lemire.me/blog/2021/05/17/converting-binary-integers-to-ascii-characters-apple-m1-vs-amd-zen2/#comment-584345 - ;; [2]: https://stackoverflow.com/questions/7890194/optimized-itoa-function/32818030#32818030 - (loop with digits = (make-string (count-digits/32 value) - :element-type 'base-char) - with digit - for i from (1- (length digits)) downto 0 - do (multiple-value-setq (value digit) (floor value 10)) - (setf (aref digits i) (digit-char digit)) - finally (return digits))) - -(defun digit-string/64 (value) - (declare (optimize speed) - (type (unsigned-byte 64) value)) - (loop with digits = (make-string (count-digits/64 value) - :element-type 'base-char) - with digit - for i from (1- (length digits)) downto 0 - finally (return digits) - do (multiple-value-setq (value digit) (floor value 10)) - (setf (aref digits i) (digit-char digit)))) - -(defun digit-string/128 (value) - (declare (optimize speed) - (type (unsigned-byte 128) value)) - (loop with digits = (make-string (count-digits/128 value) - :element-type 'base-char) - with digit - for i from (1- (length digits)) downto 0 - finally (return digits) - do (multiple-value-setq (value digit) (floor value 10)) - (setf (aref digits i) (digit-char digit)))) - -(defmethod quaviver:integer-digits - (client (result-type (eql 'string)) (base (eql 10)) value) - (declare (ignore client)) - (if (zerop value) - #(0) - (etypecase value - ((unsigned-byte 32) - (digit-string/32 value)) - ((unsigned-byte 64) - (digit-string/64 value)) - ((unsigned-byte 128) - (digit-string/128 value))))) - -(defmethod quaviver:integer-digits - (client (result-type (eql 'list)) base value) - (declare (ignore client)) - (if (zerop value) - (list 0) - (prog (digits digit) - next - (unless (zerop value) - (multiple-value-setq (value digit) (floor value base)) - (push digit digits) - (go next)) - (return digits)))) diff --git a/code/interface.lisp b/code/interface.lisp index 5c15d0dd..46b47570 100644 --- a/code/interface.lisp +++ b/code/interface.lisp @@ -16,9 +16,13 @@ (defgeneric float-internal-integer-form (float-type value)) -(defgeneric digits-integer (client base digits)) +(defgeneric parse-number (client base sequence + &optional start end integerp ratiop floatp float-type)) -(defgeneric integer-digits (client result-type base value)) +(defgeneric read-number (client base stream + &optional integerp ratiop floatp float-type)) + +(defgeneric write-number (client base value stream)) (defgeneric storage-size (type)) diff --git a/code/native/float-integer.lisp b/code/native/float-integer.lisp index 038eccff..bc5c34b6 100644 --- a/code/native/float-integer.lisp +++ b/code/native/float-integer.lisp @@ -23,29 +23,28 @@ trailing-point position) (system::flonum-to-string (abs value)) (declare (ignore leading-point trailing-point)) - (values (quaviver:digits-integer client base - (remove #\. digits)) + (values (quaviver:parse-digits base digits :ignore ".") (- position digits-length -1) (floor (float-sign value)))) #+ccl (multiple-value-bind (digits sign exponent) (ccl::flonum-to-string value) - (values (quaviver:digits-integer client base digits) + (values (quaviver:parse-digits base digits) exponent sign)) #+clisp (multiple-value-bind (digits k position sign) (system::decode-float-decimal value t) (declare (ignore k)) - (values (quaviver:digits-integer client base digits) + (values (quaviver:parse-digits base digits) (- position (length digits)) (floor (float-sign value)))) #+(or clasp cmucl ecl sbcl) (multiple-value-bind (position digits) #+clasp (core::float-to-digits nil value nil nil) - #+cmucl (lisp::flonum-to-digits value) - #+ecl (si::float-to-digits nil value nil nil) - #+sbcl (sb-impl::flonum-to-digits value) - (values (quaviver:digits-integer client base digits) + #+cmucl (lisp::flonum-to-digits value) + #+ecl (si::float-to-digits nil value nil nil) + #+sbcl (sb-impl::flonum-to-digits value) + (values (quaviver:parse-digits base digits) (- position (length digits)) (floor (float-sign value))))) diff --git a/code/packages.lisp b/code/packages.lisp index 3679dfb4..afd57899 100644 --- a/code/packages.lisp +++ b/code/packages.lisp @@ -8,8 +8,13 @@ #:internal-integer-float-form #:float-integer #:float-internal-integer-form - #:digits-integer - #:integer-digits + #:parse-digits + #:compose-digits + #:parse-number + #:read-digits + #:write-digits + #:read-number + #:write-number #:storage-size #:significand-bytespec #:significand-byte-form diff --git a/code/parse-digits.lisp b/code/parse-digits.lisp new file mode 100644 index 00000000..55945ed8 --- /dev/null +++ b/code/parse-digits.lisp @@ -0,0 +1,33 @@ +(in-package #:quaviver) + +(defun quaviver:parse-digits + (base string + &key (start 0) (end (length string)) + limit ignore) + (prog ((result 0) + (count 0) + (leading-zero 0) + (discarded 0) + (ignored 0) + digit) + next + (when (< start end) + (when (find (elt string start) ignore) + (incf start) + (incf ignored) + (go next)) + (setf digit (digit-char-p (elt string start) base)) + (cond ((null digit) + (go terminate)) + ((or (null limit) + (< count limit)) + (setf result (+ (* result base) digit)) + (if (zerop result) + (incf leading-zero) + (incf count))) + (t + (incf discarded))) + (incf start) + (go next)) + terminate + (return (values result start count leading-zero discarded ignored)))) diff --git a/code/read-digits.lisp b/code/read-digits.lisp new file mode 100644 index 00000000..ebce0352 --- /dev/null +++ b/code/read-digits.lisp @@ -0,0 +1,38 @@ +(in-package #:quaviver) + +(defun read-digits (base stream &key limit ignore) + (prog ((result 0) + (count 0) + (discarded 0) + (ignored 0) + (leading-zero 0) + char + digit + (is-empty t)) + next + (setf char (read-char stream nil)) + (unless char + (go terminate)) + (when (find char ignore) + (incf ignored) + (go next)) + (setf digit (digit-char-p char base)) + (cond ((null digit) + (unread-char char stream) + (go terminate)) + ((or (null limit) + (< count limit)) + (setf result (+ (* result base) digit) + is-empty nil) + (if (zerop result) + (incf leading-zero) + (incf count))) + (t + (incf discarded))) + (go next) + terminate + (return (values result + (if is-empty 0 count) + leading-zero + discarded + ignored)))) diff --git a/code/write-digits.lisp b/code/write-digits.lisp new file mode 100644 index 00000000..f53d648b --- /dev/null +++ b/code/write-digits.lisp @@ -0,0 +1,220 @@ +(in-package #:quaviver) + +(defun group-marker-p (index spec) + (cond ((zerop index) + nil) + ((plusp index) + (prog ((gid (position-if #'plusp spec))) + (unless gid + (return nil)) + next + (cond ((< (1+ gid) (length spec)) + (decf index (aref spec gid)) + (incf gid) + (go next)) + (t + (setf index (mod index (aref spec gid))))) + (return (zerop index)))) + (t + (prog ((gid (position-if #'minusp spec :from-end t))) + (unless gid + (return nil)) + next + (cond ((plusp gid) + (decf index (aref spec gid)) + (decf gid) + (go next)) + (t + (setf index (mod index (aref spec gid))))) + (return (zerop index)))))) + +(defun %write-smallnum-digits (base value stream fractional-position fractional-marker + digit-grouping group-marker + leading-zeros digit-char) + (let* ((power (quaviver.math:count-digits base value)) + (fractional-position (or fractional-position power)) + (pos (- (min fractional-position 0) + leading-zeros)) + digit + digits-written-p + (zero-char (funcall digit-char 0 base))) + (flet ((write-digit (ch) + (when (and digits-written-p + digit-grouping + group-marker + (group-marker-p (- fractional-position pos) + digit-grouping)) + (write-char group-marker stream)) + (write-char ch stream) + (incf pos) + (setf digits-written-p t) + (when (and fractional-marker + (= pos fractional-position)) + (write-char fractional-marker stream)))) + (tagbody + (when (and fractional-marker + (not (plusp fractional-position)) + (zerop leading-zeros)) + (write-char fractional-marker stream)) + lead + (when (plusp leading-zeros) + (write-digit zero-char) + (decf leading-zeros) + (go lead)) + head + (when (minusp pos) + (write-digit zero-char) + (go head)) + next + (decf power) + (when (plusp power) + (multiple-value-setq (digit value) + (floor value (expt base power))) + (write-digit (funcall digit-char digit base)) + (go next)) + (write-digit (funcall digit-char value base)) + tail + (when (and fractional-position + (< pos fractional-position)) + (write-digit zero-char) + (go tail))))) + value) + +;; Algorithm by Harald Hanche-Olsen, sbcl-devel 2005-02-05 +(defun %write-bignum-digits (base value stream fractional-position fractional-marker + digit-grouping group-marker + leading-zeros digit-char) + (declare (type bignum value) + (type fixnum base)) + (let* ((power (quaviver.math:count-digits base value)) + (fractional-position (or fractional-position power)) + (pos (- (min fractional-position 0) + leading-zeros)) + digit + digits-written-p + (zero-char (funcall digit-char 0 base))) + (labels ((write-digit (ch) + (when (and digits-written-p + digit-grouping + group-marker + (group-marker-p (- fractional-position pos) + digit-grouping)) + (write-char group-marker stream)) + (write-char ch stream) + (incf pos) + (setf digits-written-p t) + (when (and fractional-marker + (= pos fractional-position)) + (write-char fractional-marker stream))) + (bisect (value k exactp) + (declare (fixnum k)) + ;; VALUE is the number to bisect + ;; K on initial entry BASE^(2^K) > VALUE + ;; EXACTP is true if 2^K is the exact number of digits + (cond ((zerop value) + (when exactp + (loop repeat (ash 1 k) + do (write-digit zero-char)))) + ((zerop k) + (write-digit (funcall digit-char value base))) + (t + (decf k) + (multiple-value-bind (q r) + (truncate value (expt base (expt 2 k))) + ;; EXACTP is NIL only at the head of the + ;; initial number, as we don't know the number + ;; of digits there, but we do know that it + ;; doesn't get any leading zeros. + (bisect q k exactp) + (bisect r k (or exactp (plusp q)))))))) + (loop repeat leading-zeros + do (write-digit zero-char)) + (when (and fractional-marker + (not (plusp fractional-position)) + (zerop leading-zeros)) + (write-char fractional-marker stream)) + (when (minusp fractional-position) + (loop repeat (- fractional-position) + do (write-digit zero-char))) + (bisect value + (integer-length + (quaviver.math:ceiling-log-expt + base + 2 + (integer-length value))) + nil) + (when (>= fractional-position pos) + (loop repeat (- fractional-position pos) + do (write-digit zero-char))))) + value) + +(defun %write-pow2-digits (base value stream fractional-position fractional-marker + digit-grouping group-marker + leading-zeros digit-char) + (let* ((size (1- (integer-length base))) + (position (* size (ceiling (integer-length value) size))) + (fractional-position (or fractional-position + (ceiling (integer-length value) size))) + (pos (- (min fractional-position 0) + leading-zeros)) + digit + digits-written-p + (zero-char (funcall digit-char 0 base))) + (flet ((write-digit (ch) + (when (and digits-written-p + digit-grouping + group-marker + (group-marker-p (- fractional-position pos) + digit-grouping)) + (write-char group-marker stream)) + (write-char ch stream) + (incf pos) + (setf digits-written-p t) + (when (and fractional-marker + (= pos fractional-position)) + (write-char fractional-marker stream)))) + (tagbody + (when (and fractional-marker + (minusp fractional-position) + (zerop leading-zeros)) + (write-char fractional-marker stream)) + lead + (when (plusp leading-zeros) + (write-digit zero-char) + (decf leading-zeros) + (go lead)) + head + (when (minusp pos) + (write-digit zero-char) + (go head)) + next + (decf position size) + (unless (minusp position) + (setf digit (ldb (byte size position) value)) + (write-digit (funcall digit-char digit base)) + (go next)) + tail + (when (and fractional-position + (< pos fractional-position)) + (write-digit zero-char) + (go tail)))))) + +(defun write-digits (base value stream + &key fractional-position fractional-marker + digit-grouping group-marker + leading-zeros (digit-char 'digit-char)) + (cond ((= (logcount base) 1) + (%write-pow2-digits base value stream + fractional-position fractional-marker + digit-grouping group-marker + (or leading-zeros 0) digit-char)) + ((<= (integer-length value) 256) + (%write-smallnum-digits base value stream + fractional-position fractional-marker + digit-grouping group-marker + (or leading-zeros 0) digit-char)) + (t + (%write-bignum-digits base value stream + fractional-position fractional-marker + digit-grouping group-marker + (or leading-zeros 0) digit-char)))) diff --git a/quaviver.asd b/quaviver.asd index 9bbfb7d7..5e260c26 100644 --- a/quaviver.asd +++ b/quaviver.asd @@ -2,7 +2,7 @@ (defsystem "quaviver" :description "A portable and extensible floating point string library" - :license "MIT AND (Apache-2.0 WITH LLVM-exception OR BSL-1.0)" + :license "MIT" :author ("Robert Strandh" "Paul A. Patience" "Tarn W. Burton") @@ -38,8 +38,11 @@ (:file "integer-float") (:file "float-internal-integer-form") (:file "float-integer") - (:file "digits-integer") - (:file "integer-digits"))))) + (:file "parse-digits") + (:file "compose-digits") + (:file "read-digits") + (:file "write-digits") + (:file "number-parser"))))) (defsystem "quaviver/trailing-zeros" :description "Trailing zero removal" From 701d3938c3c99bb105c3a2ae18b5b6b0b08de7b1 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Mon, 22 Jul 2024 10:16:27 -0400 Subject: [PATCH 04/16] liebler: disable type check to allow for bignum significands --- code/liebler/implementation.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/code/liebler/implementation.lisp b/code/liebler/implementation.lisp index 0989fabd..c3c15dc6 100644 --- a/code/liebler/implementation.lisp +++ b/code/liebler/implementation.lisp @@ -12,7 +12,7 @@ (let* ((extra 6) (word-size (+ extra significand-size))) `(locally - (declare (type (unsigned-byte ,word-size) + (declare #+(or)(type (unsigned-byte ,word-size) ,significand-var) (type (or quaviver:exponent-word keyword) ,exponent-var) (type fixnum ,sign-var) From 922c8f6025c7ae924fb29875181aede0047fa9cf Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Mon, 22 Jul 2024 10:17:55 -0400 Subject: [PATCH 05/16] condition: add parse-error conditions --- code/condition/parse-error.lisp | 62 +++++++++++++++++++++++++++++++++ code/packages.lisp | 7 +++- quaviver.asd | 3 +- 3 files changed, 70 insertions(+), 2 deletions(-) create mode 100644 code/condition/parse-error.lisp diff --git a/code/condition/parse-error.lisp b/code/condition/parse-error.lisp new file mode 100644 index 00000000..061bc320 --- /dev/null +++ b/code/condition/parse-error.lisp @@ -0,0 +1,62 @@ +(in-package #:quaviver.condition) + +(define-condition assertion-failed-error (parse-error) + ((message :reader assertion-failed-error-message + :initarg :message + :initform nil)) + (:report (lambda (condition stream) + (format stream "Parsing assertion failed~@[: ~a~]." + (assertion-failed-error-message condition))))) + +(define-condition invalid-character-error (parse-error) + ((found :reader invalid-character-error-found + :initarg :found + :initform nil) + (expected :reader invalid-character-error-expected + :initarg :expected + :initform nil)) + (:report (lambda (condition stream) + (format stream "Expected ~:[end of input~;~:*~s~] but found ~:[end of input~;~:*~s~] instead." + (invalid-character-error-expected condition) + (invalid-character-error-found condition))))) + +(define-condition invalid-leading-zeros-error (parse-error) + ((part :reader invalid-leading-zeros-error-part + :initarg :part + :initform nil) + (count :reader invalid-leading-zeros-error-count + :initarg :count + :initform 0)) + (:report (lambda (condition stream) + (format stream "Found ~d invalid leading zero~p in the ~(~a~)." + (invalid-leading-zeros-error-count condition) + (invalid-leading-zeros-error-count condition) + (invalid-leading-zeros-error-part condition))))) + +(define-condition invalid-property-error (parse-error) + ((name :reader invalid-property-error-name + :initarg :name + :initform nil) + (value :reader invalid-property-error-value + :initarg :value + :initform nil) + (expected :reader invalid-property-error-expected + :initarg :expected + :initform nil)) + (:report (lambda (condition stream) + (format stream "Expected property ~s to have the value ~s but it has the value of ~s instead." + (invalid-property-error-name condition) + (invalid-property-error-expected condition) + (invalid-property-error-value condition))))) + +(define-condition missing-digits-error (parse-error) + ((part :reader missing-digits-error-part + :initarg :part + :initform nil) + (found :reader missing-digits-error-found + :initarg :found + :initform nil)) + (:report (lambda (condition stream) + (format stream "Expected digits~@[ for ~(~a~)~] but found ~:[end of input~;~:*~s~] instead." + (missing-digits-error-part condition) + (missing-digits-error-found condition))))) diff --git a/code/packages.lisp b/code/packages.lisp index afd57899..0f13cb6f 100644 --- a/code/packages.lisp +++ b/code/packages.lisp @@ -78,4 +78,9 @@ (:shadow #:floating-point-overflow #:floating-point-underflow) (:export #:floating-point-overflow - #:floating-point-underflow)) + #:floating-point-underflow + #:assertion-failed-error + #:invalid-character-error + #:invalid-leading-zeros-error + #:invalid-property-error + #:missing-digits-error)) diff --git a/quaviver.asd b/quaviver.asd index 5e260c26..58a700f3 100644 --- a/quaviver.asd +++ b/quaviver.asd @@ -19,7 +19,8 @@ :components ((:file "packages") (:module "condition" :serial t - :components ((:file "utility"))) + :components ((:file "utility") + (:file "parse-error"))) (:file "interface") (:file "traits") (:module "math" From c0cb6ee880b53914c212b1a4c0359a83b451fa64 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Mon, 22 Jul 2024 10:19:07 -0400 Subject: [PATCH 06/16] quaviver: add define-number-parser --- code/number-parser.lisp | 524 ++++++++++++++++++++++++++++++++++++++++ code/packages.lisp | 3 +- 2 files changed, 526 insertions(+), 1 deletion(-) create mode 100644 code/number-parser.lisp diff --git a/code/number-parser.lisp b/code/number-parser.lisp new file mode 100644 index 00000000..60fe1401 --- /dev/null +++ b/code/number-parser.lisp @@ -0,0 +1,524 @@ +(in-package #:quaviver) + +(defvar *variable-map* nil) + +(defvar *back-tag* nil) + +(defvar *next-tag* nil) + +(defvar *bindings* nil) + +(defvar *current-backp* nil) + +(defvar *character-test* 'equalp) + +(defvar *definitions* nil) + +(defun expand-ref (name) + (getf *variable-map* name)) + +(defun expand-set (&rest properties) + (when properties + `((setf ,@(loop for (name value) on properties by #'cddr + collect (expand-ref name) + collect value))))) + +(defgeneric expand-clause (variant key &optional items)) + +(defmethod expand-clause (variant (key cons) &optional items) + (declare (ignore items)) + (expand-clause variant (car key) (cdr key))) + +(defmethod expand-clause ((variant (eql 'read-number)) (key (eql :digits)) &optional items) + (alexandria:with-gensyms + (value count leading-zero) + (destructuring-bind (name &key ignore ((:leading-zeros leading-zeros-p) t)) + items + `((multiple-value-bind (,value ,count ,leading-zero) + (read-digits ,(expand-ref (ecase name + (:integral :integral-base) + (:fractional :fractional-base) + (:divisor :divisor-base) + (:exponent :exponent-base))) + ,(expand-ref :stream) + :ignore ,(if (or (null ignore) + (stringp ignore)) + ignore + `(funcall ,ignore ,(expand-ref :client)))) + (cond ((or (plusp ,count) (plusp ,leading-zero)) + ,@(when *current-backp* + `((setf ,(car *current-backp*) nil)))) + ,@(when *current-backp* + `((,(car *current-backp*) + (go ,*back-tag*)))) + (t + (error 'quaviver.condition:missing-digits-error + :part ,name + :found (peek-char nil ,(expand-ref :stream) nil)))) + ,@(unless leading-zeros-p + `((when (or (and (> ,leading-zero 1) + (zerop ,value)) + (and (plusp ,leading-zero) + (not (zerop ,value)))) + (error 'quaviver.condition:invalid-leading-zeros-error + :part ,name + :count ,leading-zero)))) + ,@(expand-set name value + (ecase name + (:integral :integral-count) + (:fractional :fractional-count) + (:divisor :divisor-count) + (:exponent :exponent-count)) + count + (ecase name + (:integral :integral-leading-zero) + (:fractional :fractional-leading-zero) + (:divisor :divisor-leading-zero) + (:exponent :exponent-leading-zero)) + leading-zero) + (go ,*next-tag*)))))) + +(defmethod expand-clause ((variant (eql 'parse-number)) (key (eql :digits)) &optional items) + (alexandria:with-gensyms + (value start count leading-zero) + (destructuring-bind (name &key ignore ((:leading-zeros leading-zeros-p) t)) + items + `((multiple-value-bind (,value ,start ,count ,leading-zero) + (parse-digits ,(expand-ref (ecase name + (:integral :integral-base) + (:fractional :fractional-base) + (:divisor :divisor-base) + (:exponent :exponent-base))) + ,(expand-ref :sequence) + :start ,(expand-ref :start) + :end ,(expand-ref :end) + :ignore ,(if (or (null ignore) + (stringp ignore)) + ignore + `(funcall ,ignore ,(expand-ref :client)))) + (cond ((or (plusp ,count) (plusp ,leading-zero)) + ,@(when *current-backp* + `((setf ,(car *current-backp*) nil)))) + ,@(when *current-backp* + `((,(car *current-backp*) + (go ,*back-tag*)))) + (t + (error 'quaviver.condition:missing-digits-error + :part ,name + :found (and (< ,(expand-ref :start) + ,(expand-ref :end)) + (char ,(expand-ref :sequence) + ,(expand-ref :start)))))) + ,@(unless leading-zeros-p + `((when (or (and (> ,leading-zero 1) + (zerop ,value)) + (and (plusp ,leading-zero) + (not (zerop ,value)))) + (error 'quaviver.condition:invalid-leading-zeros-error + :part ,name + :count ,leading-zero)))) + ,@(expand-set :start start + name value + (ecase name + (:integral :integral-count) + (:fractional :fractional-count) + (:divisor :divisor-count) + (:exponent :exponent-count)) + count + (ecase name + (:integral :integral-leading-zero) + (:fractional :fractional-leading-zero) + (:divisor :divisor-leading-zero) + (:exponent :exponent-leading-zero)) + leading-zero) + (go ,*next-tag*)))))) + +(defmethod expand-clause ((variant (eql 'read-number)) (key (eql :digits?)) &optional items) + (alexandria:with-gensyms + (value count leading-zero) + (destructuring-bind (name &key ignore ((:leading-zeros leading-zeros-p) t)) + items + `((multiple-value-bind (,value ,count ,leading-zero) + (read-digits ,(expand-ref (ecase name + (:integral :integral-base) + (:fractional :fractional-base) + (:divisor :divisor-base) + (:exponent :exponent-base))) + ,(expand-ref :stream) + :ignore ,(if (or (null ignore) + (stringp ignore)) + ignore + `(funcall ,ignore ,(expand-ref :client)))) + (declare (ignorable ,count ,leading-zero)) + ,@(when *current-backp* + `((when (or (plusp ,count) (plusp ,leading-zero)) + (setf ,(car *current-backp*) nil)))) + ,@(unless leading-zeros-p + `((when (or (and (> ,leading-zero 1) + (zerop ,value)) + (and (plusp ,leading-zero) + (not (zerop ,value)))) + (error 'quaviver.condition:invalid-leading-zeros-error + :part ,name + :count ,leading-zero)))) + ,@(expand-set name value + (ecase name + (:integral :integral-count) + (:fractional :fractional-count) + (:divisor :divisor-count) + (:exponent :exponent-count)) + count + (ecase name + (:integral :integral-leading-zero) + (:fractional :fractional-leading-zero) + (:divisor :divisor-leading-zero) + (:exponent :exponent-leading-zero)) + leading-zero) + ,@(when *next-tag* + `((go ,*next-tag*)))))))) + +(defmethod expand-clause ((variant (eql 'parse-number)) (key (eql :digits?)) &optional items) + (alexandria:with-gensyms + (value start count leading-zero) + (destructuring-bind (name &key ignore ((:leading-zeros leading-zeros-p) t)) + items + `((multiple-value-bind (,value ,start ,count ,leading-zero) + (parse-digits ,(expand-ref (ecase name + (:integral :integral-base) + (:fractional :fractional-base) + (:divisor :divisor-base) + (:exponent :exponent-base))) + ,(expand-ref :sequence) + :start ,(expand-ref :start) + :end ,(expand-ref :end) + :ignore ,(if (or (null ignore) + (stringp ignore)) + ignore + `(funcall ,ignore ,(expand-ref :client)))) + (declare (ignorable ,count ,leading-zero)) + ,@(when *current-backp* + `((when (or (plusp ,count) (plusp ,leading-zero)) + (setf ,(car *current-backp*) nil)))) + ,@(unless leading-zeros-p + `((when (or (and (> ,leading-zero 1) + (zerop ,value)) + (and (plusp ,leading-zero) + (not (zerop ,value)))) + (error 'quaviver.condition:invalid-leading-zeros-error + :part ,name + :count ,leading-zero)))) + ,@(expand-set :start start + name value + (ecase name + (:integral :integral-count) + (:fractional :fractional-count) + (:divisor :divisor-count) + (:exponent :exponent-count)) + count + (ecase name + (:integral :integral-leading-zero) + (:fractional :fractional-leading-zero) + (:divisor :divisor-leading-zero) + (:exponent :exponent-leading-zero)) + leading-zero) + (go ,*next-tag*)))))) + +(defmethod expand-clause (variant (key (eql :sequence)) &optional items) + `(,@(loop with outer-next-tag = *next-tag* + for (item . rest) on items + for pos from 0 + for *next-tag* = (if rest + (alexandria:make-gensym '#:next) + outer-next-tag) + nconc (expand-clause variant item) + when rest + collect *next-tag*))) + +(defmethod expand-clause (variant (key (eql :sequence?)) &optional items) + (let ((backp (alexandria:make-gensym '#:backp)) + (outer-next-tag *next-tag*) + (next-tag (alexandria:make-gensym '#:next))) + (push `(,backp ,t) *bindings*) + `(,@(loop with *back-tag* = *next-tag* + with *current-backp* = (list* backp *current-backp*) + for (item . rest) on items + for *next-tag* = (if rest (alexandria:make-gensym '#:next) next-tag) + nconc (expand-clause variant item) + when rest + collect *next-tag*) + ,next-tag + ,@(when *current-backp* + `((unless ,backp + (setf ,(car *current-backp*) nil)))) + (go ,outer-next-tag)))) + +(defmethod expand-clause (variant (key (eql :alternate)) &optional items) + (let ((backp (alexandria:make-gensym '#:backp)) + (outer-next-tag *next-tag*) + (next-tag (alexandria:make-gensym '#:next))) + (push `(,backp ,t) *bindings*) + `(,@(loop with *next-tag* = next-tag + with *current-backp* = (list* backp *current-backp*) + for (item . rest) on items + for *back-tag* = (alexandria:make-gensym '#:back) + while rest + nconc (expand-clause variant item) + collect *back-tag* + when (cdr rest) + collect `(setf ,(car *current-backp*) t)) + ,@(expand-clause variant (car (last items))) + ,next-tag + ,@(when *current-backp* + `((unless ,backp + (setf ,(car *current-backp*) nil)))) + (go ,outer-next-tag)))) + +(defmethod expand-clause (variant (key (eql :alternate?)) &optional items) + (let ((*current-backp* (list* (alexandria:make-gensym '#:backp) *current-backp*)) + (outer-next-tag *next-tag*) + (*next-tag* (alexandria:make-gensym '#:next))) + (push `(,(car *current-backp*) ,t) *bindings*) + `(,@(loop for (item . rest) on items + for *back-tag* = (if rest (alexandria:make-gensym '#:back) outer-next-tag) + nconc (expand-clause variant item) + when rest + collect *back-tag* + when (cdr rest) + collect `(setf ,(car *current-backp*) t)) + ,*next-tag* + ,@(when (cdr *current-backp*) + `((unless ,(car *current-backp*) + (setf ,(cadr *current-backp*) nil)))) + (go ,outer-next-tag)))) + +(defmethod expand-clause ((variant (eql 'read-number)) (expected character) &optional items) + (declare (ignore items)) + `((setf ,(expand-ref :character) (peek-char nil ,(expand-ref :stream) nil)) + (cond ((,*character-test* ,(expand-ref :character) ,expected) + (read-char ,(expand-ref :stream) nil) + ,@(when *current-backp* + `((setf ,(car *current-backp*) nil))) + (go ,*next-tag*)) + ,@(when *current-backp* + `((,(car *current-backp*) + (go ,*back-tag*)))) + (t + (error 'quaviver.condition:invalid-character-error + :found ,(expand-ref :character) + :expected ,expected))))) + +(defmethod expand-clause ((variant (eql 'parse-number)) (expected character) &optional items) + (declare (ignore items)) + `((setf ,(expand-ref :character) + (and (< ,(expand-ref :start) ,(expand-ref :end)) + (char ,(expand-ref :sequence) ,(expand-ref :start)))) + (cond ((,*character-test* ,(expand-ref :character) ,expected) + (incf ,(expand-ref :start)) + ,@(when *current-backp* + `((setf ,(car *current-backp*) nil))) + (go ,*next-tag*)) + ,@(when *current-backp* + `((,(car *current-backp*) + (go ,*back-tag*)))) + (t + (error 'quaviver.condition:invalid-character-error + :found ,(expand-ref :character) + :expected ,expected))))) + +(defmethod expand-clause (variant (key string) &optional items) + (declare (ignore items)) + (expand-clause variant :sequence (coerce key 'list))) + +(defmethod expand-clause (variant (key (eql :assert)) &optional items) + (declare (ignore variant)) + (destructuring-bind (name-or-func &optional value-or-message) + items + (if (keywordp name-or-func) + (let ((ref (expand-ref name-or-func))) + `((cond ((eql ,ref ,value-or-message) + (go ,*next-tag*)) + ,@(when *current-backp* + `((,(car *current-backp*) + (go ,*back-tag*)))) + (t + (error 'quaviver.condition:invalid-property-error + :name ,name-or-func + :value ,ref + :expected ,value-or-message))))) + `((cond ((funcall ,name-or-func ,(expand-ref :client)) + (go ,*next-tag*)) + ,@(when *current-backp* + `((,(car *current-backp*) + (go ,*back-tag*)))) + (t + (error 'quaviver.condition:assertion-failed-error + :message ,value-or-message))))))) + +(defmethod expand-clause (variant (key (eql :set)) &optional items) + `(,@(apply #'expand-set items) + (go ,*next-tag*))) + +(defmethod expand-clause (variant (name symbol) &optional items) + (declare (ignore items)) + (expand-clause variant (getf *definitions* name))) + +(defun expand-parser (variant definitions items integerp ratiop floatp &rest map) + (alexandria:with-gensyms + (integral integral-count integral-leading-zero integral-base + fractional fractional-count fractional-leading-zero fractional-base + divisor divisor-count divisor-leading-zero divisor-base + exponent exponent-count exponent-leading-zero exponent-base + exponent-sign sign character code payload) + (let* ((*next-tag* (alexandria:make-gensym '#:next)) + (*back-tag* nil) + (*variable-map* `(:integral ,integral + :integral-count ,integral-count + :integral-leading-zero ,integral-leading-zero + :integral-base ,integral-base + :fractional ,fractional + :fractional-count ,fractional-count + :fractional-leading-zero ,fractional-leading-zero + :fractional-base ,fractional-base + :divisor ,divisor + :divisor-count ,divisor-count + :divisor-leading-zero ,divisor-leading-zero + :divisor-base ,divisor-base + :exponent-sign ,exponent-sign + :exponent ,exponent + :exponent-count ,exponent-count + :exponent-leading-zero ,exponent-leading-zero + :exponent-base ,exponent-base + :sign ,sign + :character ,character + :code ,code + :payload ,payload + ,@map)) + (*current-backp* nil) + (*bindings* nil) + (*definitions* definitions) + (expanded-clauses (expand-clause variant :sequence items))) + `(prog ((,integral 0) + (,integral-count 0) + (,integral-leading-zero 0) + (,integral-base base) + (,fractional 0) + (,fractional-count 0) + (,fractional-leading-zero 0) + (,fractional-base base) + (,divisor 1) + (,divisor-count 0) + (,divisor-leading-zero 0) + (,divisor-base base) + (,exponent-sign 1) + (,exponent 0) + (,exponent-count 0) + (,exponent-leading-zero 0) + (,exponent-base base) + (,sign 1) + (,character nil) + (,code nil) + (,payload 0) + ,@*bindings*) + (declare (ignorable ,integral ,integral-count ,integral-leading-zero ,integral-base + ,fractional ,fractional-count ,fractional-leading-zero ,fractional-base + ,divisor ,divisor-count, divisor-leading-zero ,divisor-base + ,exponent-sign ,exponent ,exponent-count ,exponent-leading-zero ,exponent-base + ,sign ,character)) + ,@expanded-clauses + ,*next-tag* + (cond (,code + (return (quaviver:integer-float ,(expand-ref :client) + ,(expand-ref :float-type) + ,(expand-ref :base) + ,payload + ,code + ,sign))) + ,@(when integerp + `(((and ,(expand-ref :integer) + (or (plusp ,sign) + (not (zerop ,integral)))) + (return (* ,sign ,integral))))) + ,@(when ratiop + `(((and ,(expand-ref :ratio) + (or (plusp ,sign) + (not (zerop ,integral)))) + (return (/ (* ,sign ,integral) ,divisor))))) + ,@(when floatp + `((,(expand-ref :float) + (return (quaviver:integer-float ,(expand-ref :client) + ,(expand-ref :float-type) + ,(expand-ref :base) + (if (zerop ,integral) + ,fractional + (+ (* (expt ,(expand-ref :base) + (+ ,fractional-count + ,fractional-leading-zero)) + ,integral) + ,fractional)) + (- (* ,exponent-sign ,exponent) + ,fractional-count + ,fractional-leading-zero) + ,sign))))) + (t + (error 'parse-error))))))) + +(defmacro define-number-parser ((&key client + base + ((:integer integerp) t) + ((:ratio ratiop) t) + ((:float floatp) t) + (float-type '*read-default-float-format*) + ((:case casep) nil)) + definitions + &body items) + (let ((*character-test* (if casep 'equal 'equalp))) + `(progn + (defmethod read-number + (,(if client + `(client ,client) + 'client) + ,(if base + `(base (eql ,base)) + 'base) + stream + &optional (integerp t) (ratiop t) (floatp t) + float-type) + (declare (ignorable integerp ratiop floatp)) + (unless float-type + (setf float-type ,float-type)) + ,(expand-parser 'read-number definitions items + integerp ratiop floatp + :client 'client + :stream 'stream + :base 'base + :float-type 'float-type + :integer 'integerp + :ratio 'ratiop + :float 'floatp)) + + (defmethod parse-number + (,(if client + `(client ,client) + 'client) + ,(if base + `(base (eql ,base)) + 'base) + sequence + &optional (start 0) (end (length sequence)) + (integerp t) (ratiop t) (floatp t) + float-type) + (declare (ignorable integerp ratiop floatp)) + (unless float-type + (setf float-type ,float-type)) + (values ,(expand-parser 'parse-number definitions items + integerp ratiop floatp + :client 'client + :sequence 'sequence + :start 'start + :end 'end + :base 'base + :float-type 'float-type + :integer 'integerp + :ratio 'ratiop + :float 'floatp) + start))))) diff --git a/code/packages.lisp b/code/packages.lisp index 0f13cb6f..2d74d8ca 100644 --- a/code/packages.lisp +++ b/code/packages.lisp @@ -38,7 +38,8 @@ #:min-exponent #:arithmetic-size #:significand-word - #:exponent-word)) + #:exponent-word + #:define-number-parser)) #+clisp (pushnew :quaviver/short-float *features*) From 89b9020b65a16624db0d7866d26db388bf369c10 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Mon, 22 Jul 2024 10:24:24 -0400 Subject: [PATCH 07/16] json: new system for json serialization --- code/json/implementation.lisp | 49 +++++++++++++++++++++++++++++++++++ code/json/packages.lisp | 5 ++++ quaviver.asd | 15 +++++++++++ 3 files changed, 69 insertions(+) create mode 100644 code/json/implementation.lisp create mode 100644 code/json/packages.lisp diff --git a/code/json/implementation.lisp b/code/json/implementation.lisp new file mode 100644 index 00000000..925b64c1 --- /dev/null +++ b/code/json/implementation.lisp @@ -0,0 +1,49 @@ +(in-package #:quaviver/json) + +(defclass client () ()) + +(quaviver:define-number-parser + (:client client :ratio nil :base 10) + () + (:sequence? #\- + (:set :sign -1)) + (:digits :integral + :leading-zeros nil) + (:sequence? (:assert :float t) + #\. + (:digits :fractional) + (:set :integer nil)) + (:sequence? (:assert :float t) + #\e + (:set :integer nil) + (:alternate? #\+ + (:sequence? #\- + (:set :exponent-sign -1))) + (:digits :exponent))) + +(defmethod quaviver:write-number ((client client) base (value integer) stream) + (cond ((minusp value) + (write-char #\- stream) + (quaviver:write-digits base (- value) stream)) + (t + (quaviver:write-digits base value stream)))) + +(defmethod quaviver:write-number ((client client) base (value float) stream) + (multiple-value-bind (significand exponent sign) + (quaviver:float-integer client base value) + (when (keywordp exponent) + (error "Unable to represent ~a in JSON." exponent)) + (when (minusp sign) + (write-char #\- stream)) + (let ((len (quaviver.math:ceiling-log-expt 10 2 (integer-length significand)))) + (cond ((<= (- len) exponent -1) + (when (eql (- len) exponent) + (write-char #\0 stream)) + (quaviver:write-digits base significand stream + :fractional-position (+ len exponent) + :fractional-marker #\.)) + (t + (quaviver:write-digits base significand stream) + (unless (zerop exponent) + (write-char #\e stream) + (quaviver:write-number client base exponent stream))))))) diff --git a/code/json/packages.lisp b/code/json/packages.lisp new file mode 100644 index 00000000..51c9b42c --- /dev/null +++ b/code/json/packages.lisp @@ -0,0 +1,5 @@ +(in-package #:common-lisp-user) + +(defpackage #:quaviver/json + (:use #:common-lisp) + (:export #:client)) diff --git a/quaviver.asd b/quaviver.asd index 58a700f3..0f61363a 100644 --- a/quaviver.asd +++ b/quaviver.asd @@ -175,6 +175,21 @@ :components ((:file "packages") (:file "implementation"))))) +(defsystem "quaviver/json" + :description "JSON Serialization/Deserialization for Quaviver" + :license "MIT" + :author ("Tarn W. Burton") + :version (:read-file-form "version.sexp") + :homepage "https://github.com/s-expressionists/Quaviver" + :bug-tracker "https://github.com/s-expressionists/Quaviver/issues" + :source-control (:git "https://github.com/s-expressionists/Quaviver.git") + :depends-on ("quaviver") + :components ((:module "code" + :pathname "code/json/" + :serial t + :components ((:file "packages") + (:file "implementation"))))) + (defsystem "quaviver/ansi-test" :description "ANSI Test system for Quaviver" :license "MIT" From a3ddc60a9d5f6d52f39c6d4248881159d790145a Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Mon, 22 Jul 2024 10:25:52 -0400 Subject: [PATCH 08/16] common-lisp: new system for common lisp serialization --- code/common-lisp/implementation.lisp | 140 +++++++++++++++++++++++++++ code/common-lisp/packages.lisp | 6 ++ quaviver.asd | 15 +++ 3 files changed, 161 insertions(+) create mode 100644 code/common-lisp/implementation.lisp create mode 100644 code/common-lisp/packages.lisp diff --git a/code/common-lisp/implementation.lisp b/code/common-lisp/implementation.lisp new file mode 100644 index 00000000..d8b3c5e4 --- /dev/null +++ b/code/common-lisp/implementation.lisp @@ -0,0 +1,140 @@ +(in-package #:quaviver/common-lisp) + +(declaim (ftype (function (float) base-char) exponent-marker) + (inline exponent-marker)) + +(defun exponent-marker (value) + (if (typep value *read-default-float-format*) + #+(or ccl lispworks) #\E #-(or ccl lispworks) #\e + (etypecase value + (short-float #+(or ccl lispworks) #\S #-(or ccl lispworks) #\s) + (single-float #+(or ccl lispworks) #\F #-(or ccl lispworks) #\f) + (double-float #+(or ccl lispworks) #\D #-(or ccl lispworks) #\d) + (long-float #+(or ccl lispworks) #\L #-(or ccl lispworks) #\l)))) + +(defclass client () + ((%extended-exponent-sign :accessor extended-exponent-sign-p + :initarg :extended-exponent-sign + :initform #+ccl t #-ccl nil))) + +(quaviver:define-number-parser + (:client client) + (:exponent? (:sequence? (:assert :float t) + (:alternate #\e + (:sequence #\s + (:set :float-type 'short-float)) + (:sequence #\f + (:set :float-type 'single-float)) + (:sequence #\d + (:set :float-type 'double-float)) + (:sequence #\l + (:set :float-type 'long-float))) + (:set :integer nil :ratio nil) + (:sequence? (:assert (complement #'extended-exponent-sign-p)) + (:alternate #\+ + (:sequence #\- + (:set :exponent-sign -1)))) + (:sequence? (:assert 'extended-exponent-sign-p) + (:alternate #\+ + (:sequence #\- + (:set :exponent-sign -1))) + (:alternate? (:sequence #\+ + (:set :code :infinity)) + (:sequence #\- + (:set :code :quiet-nan)))) + (:digits :exponent))) + (:alternate? #\+ + (:sequence #\- + (:set :sign -1))) + (:alternate (:sequence (:assert :float t) + #\. + (:digits :fractional) + (:set :ratio nil + :integer nil) + :exponent?) + (:sequence (:digits :integral) + (:alternate (:sequence (:assert :ratio t) + #\/ + (:set :integer nil :float nil) + (:digits :divisor)) + (:sequence (:sequence? #\. + (:sequence? (:assert :float t) + (:digits :fractional) + (:set :ratio nil + :integer nil))) + :exponent?))))) + +(defmethod quaviver:write-number ((client client) (base (eql 2)) (value integer) stream) + (write-string "#b" stream) + (when (minusp value) + (write-char #\- stream)) + (quaviver:write-digits base (abs value) stream) + value) + +(defmethod quaviver:write-number ((client client) (base (eql 8)) (value integer) stream) + (write-string "#o" stream) + (when (minusp value) + (write-char #\- stream)) + (quaviver:write-digits base (abs value) stream) + value) + +(defmethod quaviver:write-number ((client client) (base (eql 10)) (value integer) stream) + (when (minusp value) + (write-char #\- stream)) + (quaviver:write-digits base (abs value) stream) + value) + +(defmethod quaviver:write-number ((client client) (base (eql 16)) (value integer) stream) + (write-string "#x" stream) + (when (minusp value) + (write-char #\- stream)) + (quaviver:write-digits base (abs value) stream) + value) + +(defmethod quaviver:write-number ((client client) base (value integer) stream) + (unless (<= base 36) + (error "Invalid base ~a" base)) + (write-char #\# stream) + (quaviver:write-digits 10 base stream) + (write-char #\r stream) + (when (minusp value) + (write-char #\- stream)) + (quaviver:write-digits base (abs value) stream) + value) + +(defmethod quaviver:write-number ((client client) base (value float) stream) + (declare (ignore base)) + (multiple-value-bind (significand exponent sign) + (quaviver:float-integer client 10 value) + (cond ((and (extended-exponent-sign-p client) + (eq exponent :infinity)) + (when (minusp sign) + (write-char #\- stream)) + (write-char #\1 stream) + (write-char (exponent-marker value) stream) + (write-string "++0" stream)) + ((and (extended-exponent-sign-p client) + (eq exponent :quiet-nan)) + (when (minusp sign) + (write-char #\- stream)) + (write-char #\1 stream) + (write-char (exponent-marker value) stream) + (write-string "+-0" stream)) + ((keywordp exponent) + (error "Unable to represent ~a." exponent)) + (t + (when (minusp sign) + (write-char #\- stream)) + (let ((len (quaviver.math:ceiling-log-expt 10 2 (integer-length significand)))) + (cond ((and (typep value *read-default-float-format*) + (<= (- len) exponent -1)) + (quaviver:write-digits 10 significand stream + :fractional-position (+ len exponent) + :fractional-marker #\.)) + (t + (quaviver:write-digits 10 significand stream) + (write-char (exponent-marker value) stream) + (when (minusp exponent) + (write-char #\- stream)) + (quaviver:write-digits 10 (abs exponent) stream))))))) + value) diff --git a/code/common-lisp/packages.lisp b/code/common-lisp/packages.lisp new file mode 100644 index 00000000..260fb6d9 --- /dev/null +++ b/code/common-lisp/packages.lisp @@ -0,0 +1,6 @@ +(in-package #:common-lisp-user) + +(defpackage #:quaviver/common-lisp + (:use #:common-lisp) + (:export #:client + #:extended-exponent-sign-p)) diff --git a/quaviver.asd b/quaviver.asd index 0f61363a..d8fe9504 100644 --- a/quaviver.asd +++ b/quaviver.asd @@ -175,6 +175,21 @@ :components ((:file "packages") (:file "implementation"))))) +(defsystem "quaviver/common-lisp" + :description "Common Lisp Serialization/Deserialization for Quaviver" + :license "MIT" + :author ("Tarn W. Burton") + :version (:read-file-form "version.sexp") + :homepage "https://github.com/hs-expressionists/Quaviver" + :bug-tracker "https://github.com/s-expressionists/Quaviver/issues" + :source-control (:git "https://github.com/s-expressionists/Quaviver.git") + :depends-on ("quaviver") + :components ((:module "code" + :pathname "code/common-lisp/" + :serial t + :components ((:file "packages") + (:file "implementation"))))) + (defsystem "quaviver/json" :description "JSON Serialization/Deserialization for Quaviver" :license "MIT" From 0784a851df2b55fce16262f5181708fff06b3196 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Mon, 22 Jul 2024 10:27:12 -0400 Subject: [PATCH 09/16] c: new system for c serialization --- code/c/implementation.lisp | 256 +++++++++++++++++++++++++++++++++++++ code/c/packages.lisp | 5 + quaviver.asd | 15 +++ 3 files changed, 276 insertions(+) create mode 100644 code/c/implementation.lisp create mode 100644 code/c/packages.lisp diff --git a/code/c/implementation.lisp b/code/c/implementation.lisp new file mode 100644 index 00000000..418747bf --- /dev/null +++ b/code/c/implementation.lisp @@ -0,0 +1,256 @@ +(in-package #:quaviver/c) + +(deftype c-c++-standard () + '(member :c89 :c99 :c11 :c17 :c23 + :c++98 :c++03 :c++11 :c++14 :c++17 :c++20 :c++23 :c++26)) + +(defclass client () + ((%standard :accessor client-standard + :initarg :standard + :initform :c++23 + :type c-c++-standard) + (%binary-grouping :accessor binary-grouping + :initarg :binary-grouping + :initform #(4)) + (%octal-grouping :accessor octal-grouping + :initarg :octal-grouping + :initform #(4)) + (%hexadecimal-grouping :accessor hexadecimal-grouping + :initarg :hexadecimal-grouping + :initform #(4)) + (%decimal-grouping :accessor decimal-grouping + :initarg :decimal-grouping + :initform #(-3 3)) + (%exponent-grouping :accessor exponent-grouping + :initarg :exponent-grouping + :initform #(3)))) + +(defun digit-grouping-p (client) + (and (member (client-standard client) '(:c23 :c++14 :c++17 :c++20 :c++23 :c++26)) + t)) + +(defun digit-separators (client) + (if (digit-grouping-p client) + "'" + "")) + +(defun group-marker (client) + (when (digit-grouping-p client) + #\')) + +(defun binary-integer-literals-p (client) + (and (member (client-standard client) '(:c23 :c++14 :c++17 :c++20 :c++23 :c++26)) + t)) + +(defun hexadecimal-float-literals-p (client) + (and (member (client-standard client) '(:c++17 :c++20 :c++23 :c++26)) + t)) + +(defun long-long-suffix-p (client) + (and (member (client-standard client) '(:c++11 :c++17 :c++20 :c++23 :c++26)) + t)) + +(defun size-suffix-p (client) + (and (member (client-standard client) '(:c++23 :c++26)) + t)) + +(defun float-size-suffix-p (client) + (and (member (client-standard client) '(:c++23 :c++26)) + t)) + +(quaviver:define-number-parser + (:client client :ratio nil :float-type 'double-float) + () + (:alternate? #\+ + (:sequence #\- + (:set :sign -1))) + (:alternate (:sequence #\0 + (:alternate (:sequence (:assert 'binary-integer-literals-p) + (:assert :integer t) + #\b + (:set :integral-base 2 + :float nil) + (:digits :integral + :ignore 'digit-separators)) + (:sequence #\x + (:set :integral-base 16 + :fractional-base 16 + :exponent-base 10 + :base 2) + (:digits :integral + :ignore 'digit-separators) + (:sequence? (:assert 'hexadecimal-float-literals-p) + (:assert :float t) + #\. + (:set :integer nil) + (:digits? :fractional + :ignore 'digit-separators)) + (:sequence? (:assert 'hexadecimal-float-literals-p) + (:assert :float t) + #\p + (:set :integer nil) + (:alternate? #\+ + (:sequence #\- + (:set :exponent-sign -1))) + (:digits :exponent + :ignore 'digit-separators))) + (:sequence (:assert :integer t) + (:set :integral-base 8 + :float nil) + (:digits :integral + :ignore 'digit-separators)))) + (:sequence (:digits :integral + :leading-zeros nil + :ignore 'digit-separators) + (:sequence? (:assert :float t) + #\. + (:set :integer nil) + (:digits? :fractional + :ignore 'digit-separators)) + (:sequence? (:assert :float t) + #\e + (:set :integer nil) + (:alternate? #\+ + (:sequence #\- + (:set :exponent-sign -1))) + (:digits :exponent + :ignore 'digit-separators)) + (:sequence? (:assert :integer t) + (:set :float nil)))) + (:alternate? (:sequence (:assert :float t) + #\f + (:set :float-type 'single-float) + (:sequence? (:assert 'float-size-suffix-p) + (:alternate? (:sequence #\1 + (:alternate (:sequence #\6 + #+quaviver/short-float + (:set :float-type 'short-float)) + (:sequence "28" + (:set :float-type + #+quaviver/long-float + 'long-float + #-quaviver/long-float + 'double-float)))) + (:sequence "32") + (:sequence "64" + (:set :float-type 'double-float))))) + (:sequence (:assert :float t) + #\l + #+quaviver/long-float + (:set :float-type 'long-float)) + (:sequence (:assert 'float-size-suffix-p) + (:assert :float t) + "bf16" + (:set :float-type + #+quaviver/short-float 'short-float + #-quaviver/short-float 'single-float)) + (:sequence (:assert :integer t) + #\l + (:sequence? (:assert 'long-long-suffix-p) + #\l) + (:sequence? #\u)) + (:sequence (:assert 'size-suffix-p) + (:assert :integer t) + #\z + (:sequence? #\u)) + (:sequence (:assert :integer t) + #\u + (:alternate? (:sequence #\l + (:sequence? (:assert 'long-long-suffix-p) + #\l)) + (:sequence (:assert 'size-suffix-p) + #\z))))) + +(defmethod quaviver:write-number ((client client) (base (eql 2)) (value integer) stream) + (unless (binary-integer-literals-p client) + (error "Cannot print base 2 integers in the ~a standard." (client-standard client))) + (when (minusp value) + (write-char #\- stream)) + (write-string "0b" stream) + (quaviver:write-digits base (abs value) stream + :digit-grouping (binary-grouping client) + :group-marker (group-marker client)) + value) + +(defmethod quaviver:write-number ((client client) (base (eql 8)) (value integer) stream) + (when (minusp value) + (write-char #\- stream)) + (write-char #\0 stream) + (quaviver:write-digits base (abs value) stream + :digit-grouping (octal-grouping client) + :group-marker (group-marker client)) + value) + +(defmethod quaviver:write-number ((client client) (base (eql 10)) (value integer) stream) + (when (minusp value) + (write-char #\- stream)) + (quaviver:write-digits base (abs value) stream + :digit-grouping (decimal-grouping client) + :group-marker (group-marker client)) + value) + +(defmethod quaviver:write-number ((client client) (base (eql 16)) (value integer) stream) + (when (minusp value) + (write-char #\- stream)) + (write-string "0x" stream) + (quaviver:write-digits base (abs value) stream + :digit-grouping (hexadecimal-grouping client) + :group-marker (group-marker client)) + value) + +(defun write-float-suffix (client value stream) + (declare (ignore client)) + (typecase value + (single-float + (write-char #\f stream)) + (long-float + (write-char #\l stream)))) + +(defmethod quaviver:write-number ((client client) (base (eql 10)) (value float) stream) + (multiple-value-bind (significand exponent sign) + (quaviver:float-integer client base value) + (when (keywordp exponent) + (error "Unable to represent ~a in ~a." exponent (client-standard client))) + (when (minusp sign) + (write-char #\- stream)) + (let ((len (quaviver.math:ceiling-log-expt 10 2 (integer-length significand)))) + (cond ((<= (- len) exponent -1) + (quaviver:write-digits base significand stream + :fractional-position (+ len exponent) + :fractional-marker #\. + :digit-grouping (decimal-grouping client) + :group-marker (group-marker client))) + (t + (quaviver:write-digits base significand stream + :digit-grouping (decimal-grouping client) + :group-marker (group-marker client)) + (unless (zerop exponent) + (write-char #\e stream) + (when (minusp exponent) + (write-char #\- stream)) + (quaviver:write-digits base (abs exponent) stream + :digit-grouping (exponent-grouping client) + :group-marker (group-marker client)))))) + (write-float-suffix client value stream)) + value) + +(defmethod quaviver:write-number ((client client) (base (eql 16)) (value float) stream) + (multiple-value-bind (significand exponent sign) + (quaviver:float-integer client 2 value) + (when (keywordp exponent) + (error "Unable to represent ~a in ~a." exponent (client-standard client))) + (when (minusp sign) + (write-char #\- stream)) + (write-string "0x" stream) + (quaviver:write-digits 16 significand stream + :digit-grouping (hexadecimal-grouping client) + :group-marker (group-marker client)) + (unless (zerop exponent) + (write-char #\p stream) + (when (minusp exponent) + (write-char #\- stream)) + (quaviver:write-digits 10 (abs exponent) stream + :digit-grouping (exponent-grouping client) + :group-marker (group-marker client))) + (write-float-suffix client value stream)) + value) diff --git a/code/c/packages.lisp b/code/c/packages.lisp new file mode 100644 index 00000000..8ee94c18 --- /dev/null +++ b/code/c/packages.lisp @@ -0,0 +1,5 @@ +(in-package #:common-lisp-user) + +(defpackage #:quaviver/c + (:use #:common-lisp) + (:export #:client)) diff --git a/quaviver.asd b/quaviver.asd index d8fe9504..66f5bdf0 100644 --- a/quaviver.asd +++ b/quaviver.asd @@ -175,6 +175,21 @@ :components ((:file "packages") (:file "implementation"))))) +(defsystem "quaviver/c" + :description "C/C++ Serialization/Deserialization for Quaviver" + :license "MIT" + :author ("Tarn W. Burton") + :version (:read-file-form "version.sexp") + :homepage "https://github.com/s-expressionists/Quaviver" + :bug-tracker "https://github.com/s-expressionists/Quaviver/issues" + :source-control (:git "https://github.com/s-expressionists/Quaviver.git") + :depends-on ("quaviver") + :components ((:module "code" + :pathname "code/c/" + :serial t + :components ((:file "packages") + (:file "implementation"))))) + (defsystem "quaviver/common-lisp" :description "Common Lisp Serialization/Deserialization for Quaviver" :license "MIT" From 82e43949466cb507e4178e6fdab915796e846795 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Mon, 22 Jul 2024 10:28:12 -0400 Subject: [PATCH 10/16] fortran: new system for fortran serialization --- code/fortran/implementation.lisp | 61 ++++++++++++++++++++++++++++++++ code/fortran/packages.lisp | 5 +++ quaviver.asd | 15 ++++++++ 3 files changed, 81 insertions(+) create mode 100644 code/fortran/implementation.lisp create mode 100644 code/fortran/packages.lisp diff --git a/code/fortran/implementation.lisp b/code/fortran/implementation.lisp new file mode 100644 index 00000000..25a992ce --- /dev/null +++ b/code/fortran/implementation.lisp @@ -0,0 +1,61 @@ +(in-package #:quaviver/fortran) + +(defclass client () ()) + +(quaviver:define-number-parser + (:client client :ratio nil :base 10 :case t) + () + (:alternate? #\+ + (:sequence? #\- + (:set :sign -1))) + (:alternate (:sequence #\. + (:set :integer nil) + (:digits :fractional)) + (:sequence (:digits :integral) + (:sequence? #\. + (:set :integer nil) + (:digits? :fractional)))) + (:sequence? (:assert :float t) + (:alternate (:sequence #\E + (:set :float-type 'single-float)) + (:sequence #\D + (:set :float-type 'double-float))) + (:set :integer nil) + (:alternate? #\+ + (:sequence? #\- + (:set :exponent-sign -1))) + (:digits :exponent))) + +(defmethod quaviver:write-number ((client client) (base (eql 10)) (value integer) stream) + (when (minusp value) + (write-char #\- stream)) + (quaviver:write-digits base (abs value) stream) + value) + +(defmethod quaviver:write-number ((client client) (base (eql 10)) (value single-float) stream) + (multiple-value-bind (significand exponent sign) + (quaviver:float-integer client base value) + (when (keywordp exponent) + (error "Unable to represent ~a in ~a." exponent (client-standard client))) + (when (minusp sign) + (write-char #\- stream)) + (quaviver:write-digits base significand stream) + (write-char #\E stream) + (when (minusp exponent) + (write-char #\- stream)) + (quaviver:write-digits base (abs exponent) stream)) + value) + +(defmethod quaviver:write-number ((client client) (base (eql 10)) (value double-float) stream) + (multiple-value-bind (significand exponent sign) + (quaviver:float-integer client base value) + (when (keywordp exponent) + (error "Unable to represent ~a in ~a." exponent (client-standard client))) + (when (minusp sign) + (write-char #\- stream)) + (quaviver:write-digits base significand stream) + (write-char #\D stream) + (when (minusp exponent) + (write-char #\- stream)) + (quaviver:write-digits base (abs exponent) stream)) + value) diff --git a/code/fortran/packages.lisp b/code/fortran/packages.lisp new file mode 100644 index 00000000..2aab18a0 --- /dev/null +++ b/code/fortran/packages.lisp @@ -0,0 +1,5 @@ +(in-package #:common-lisp-user) + +(defpackage #:quaviver/fortran + (:use #:common-lisp) + (:export #:client)) diff --git a/quaviver.asd b/quaviver.asd index 66f5bdf0..8fe5a435 100644 --- a/quaviver.asd +++ b/quaviver.asd @@ -205,6 +205,21 @@ :components ((:file "packages") (:file "implementation"))))) +(defsystem "quaviver/fortran" + :description "Fortran Serialization/Deserialization for Quaviver" + :license "MIT" + :author ("Tarn W. Burton") + :version (:read-file-form "version.sexp") + :homepage "https://github.com/s-expressionists/Quaviver" + :bug-tracker "https://github.com/s-expressionists/Quaviver/issues" + :source-control (:git "https://github.com/s-expressionists/Quaviver.git") + :depends-on ("quaviver") + :components ((:module "code" + :pathname "code/fortran/" + :serial t + :components ((:file "packages") + (:file "implementation"))))) + (defsystem "quaviver/json" :description "JSON Serialization/Deserialization for Quaviver" :license "MIT" From 99b43d1f276b5bdc0c4b57de6c2a754c7fe0f037 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Tue, 23 Jul 2024 07:40:43 -0400 Subject: [PATCH 11/16] blub: new system for generic serialization --- code/blub/implementation.lisp | 54 +++++++++++++++++++++++++++++++++++ code/blub/packages.lisp | 5 ++++ quaviver.asd | 15 ++++++++++ 3 files changed, 74 insertions(+) create mode 100644 code/blub/implementation.lisp create mode 100644 code/blub/packages.lisp diff --git a/code/blub/implementation.lisp b/code/blub/implementation.lisp new file mode 100644 index 00000000..751d20fa --- /dev/null +++ b/code/blub/implementation.lisp @@ -0,0 +1,54 @@ +(in-package #:quaviver/blub) + +(defclass client () ()) + +(quaviver:define-number-parser + (:client client :ratio nil :base 10) + () + (:alternate? #\+ + (:sequence? #\- + (:set :sign -1))) + (:alternate (:sequence #\. + (:set :integer nil) + (:digits :fractional)) + (:sequence (:digits :integral) + (:sequence? #\. + (:sequence? (:assert :float t) + (:digits :fractional) + (:set :integer nil))))) + (:sequence? (:assert :float t) + #\e + (:set :integer nil) + (:alternate? #\+ + (:sequence? #\- + (:set :exponent-sign -1))) + (:digits :exponent))) + +(defmethod quaviver:write-number ((client client) (base (eql 10)) (value integer) stream) + (when (minusp value) + (write-char #\- stream)) + (quaviver:write-digits base (abs value) stream) + value) + +(defmethod quaviver:write-number ((client client) (base (eql 10)) (value float) stream) + (multiple-value-bind (significand exponent sign) + (quaviver:float-integer client base value) + (when (keywordp exponent) + (error "Unable to represent ~a in ~a." exponent (client-standard client))) + (when (minusp sign) + (write-char #\- stream)) + (let ((len (quaviver.math:ceiling-log-expt 10 2 (integer-length significand)))) + (cond ((<= (- len) exponent -1) + (when (eql (- len) exponent) + (write-char #\0 stream)) + (quaviver:write-digits base significand stream + :fractional-position (+ len exponent) + :fractional-marker #\.)) + (t + (quaviver:write-digits base significand stream) + (unless (zerop exponent) + (write-char #\e stream) + (when (minusp exponent) + (write-char #\- stream)) + (quaviver:write-digits base (abs exponent) stream)))))) + value) diff --git a/code/blub/packages.lisp b/code/blub/packages.lisp new file mode 100644 index 00000000..ac2160d1 --- /dev/null +++ b/code/blub/packages.lisp @@ -0,0 +1,5 @@ +(in-package #:common-lisp-user) + +(defpackage #:quaviver/blub + (:use #:common-lisp) + (:export #:client)) diff --git a/quaviver.asd b/quaviver.asd index 8fe5a435..8601564e 100644 --- a/quaviver.asd +++ b/quaviver.asd @@ -175,6 +175,21 @@ :components ((:file "packages") (:file "implementation"))))) +(defsystem "quaviver/blub" + :description "Generic Serialization/Deserialization for Quaviver" + :license "MIT" + :author ("Tarn W. Burton") + :version (:read-file-form "version.sexp") + :homepage "https://github.com/s-expressionists/Quaviver" + :bug-tracker "https://github.com/s-expressionists/Quaviver/issues" + :source-control (:git "https://github.com/s-expressionists/Quaviver.git") + :depends-on ("quaviver") + :components ((:module "code" + :pathname "code/blub/" + :serial t + :components ((:file "packages") + (:file "implementation"))))) + (defsystem "quaviver/c" :description "C/C++ Serialization/Deserialization for Quaviver" :license "MIT" From aa94f708655a2bed4b0ea16e754a77bc8d4b1b5f Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Wed, 24 Jul 2024 06:37:11 -0400 Subject: [PATCH 12/16] python: new system for Python serialization --- code/python/implementation.lisp | 143 ++++++++++++++++++++++++++++++++ code/python/packages.lisp | 5 ++ quaviver.asd | 15 ++++ 3 files changed, 163 insertions(+) create mode 100644 code/python/implementation.lisp create mode 100644 code/python/packages.lisp diff --git a/code/python/implementation.lisp b/code/python/implementation.lisp new file mode 100644 index 00000000..e3736c13 --- /dev/null +++ b/code/python/implementation.lisp @@ -0,0 +1,143 @@ +(in-package #:quaviver/python) + +(defclass client () + ((%version :accessor version + :initarg :version + :initform "3.6") + (%binary-grouping :accessor binary-grouping + :initarg :binary-grouping + :initform #(4)) + (%octal-grouping :accessor octal-grouping + :initarg :octal-grouping + :initform #(4)) + (%hexadecimal-grouping :accessor hexadecimal-grouping + :initarg :hexadecimal-grouping + :initform #(4)) + (%decimal-grouping :accessor decimal-grouping + :initarg :decimal-grouping + :initform #(-3 3)) + (%exponent-grouping :accessor exponent-grouping + :initarg :exponent-grouping + :initform #(3)))) + +(defun digit-grouping-p (client) + (uiop:version<= "3.6" (version client))) + +(defun digit-separators (client) + (if (digit-grouping-p client) + "_" + "")) + +(defun group-marker (client) + (when (digit-grouping-p client) + #\_)) + +(quaviver:define-number-parser + (:client client :ratio nil :float-type 'double-float) + (:exponent? (:sequence? (:assert :float t) + #\e + (:set :integer nil) + (:alternate? #\+ + (:sequence #\- + (:set :exponent-sign -1))) + (:digits :exponent + :ignore 'digit-separators))) + (:alternate? #\+ + (:sequence #\- + (:set :sign -1))) + (:alternate (:sequence #\0 + (:alternate (:sequence (:assert :integer t) + #\b + (:set :integral-base 2 + :float nil) + (:digits :integral + :ignore 'digit-separators)) + (:sequence (:assert :integer t) + #\x + (:set :integral-base 16 + :float nil) + (:digits :integral + :ignore 'digit-separators)) + (:sequence (:assert :integer t) + #\o + (:set :integral-base 8 + :float nil) + (:digits :integral + :ignore 'digit-separators)))) + (:sequence (:assert :float t) + #\. + (:set :integer nil) + (:digits :fractional + :ignore 'digit-separators) + :exponent?) + (:sequence (:digits :integral + :leading-zeros nil + :ignore 'digit-separators) + (:sequence? (:assert :float t) + #\. + (:set :integer nil) + (:digits? :fractional + :ignore 'digit-separators)) + :exponent?))) + +(defmethod quaviver:write-number ((client client) (base (eql 2)) (value integer) stream) + (when (minusp value) + (write-char #\- stream)) + (write-string "0b" stream) + (quaviver:write-digits base (abs value) stream + :digit-grouping (binary-grouping client) + :group-marker (group-marker client)) + value) + +(defmethod quaviver:write-number ((client client) (base (eql 8)) (value integer) stream) + (when (minusp value) + (write-char #\- stream)) + (write-string "0o" stream) + (quaviver:write-digits base (abs value) stream + :digit-grouping (octal-grouping client) + :group-marker (group-marker client)) + value) + +(defmethod quaviver:write-number ((client client) (base (eql 10)) (value integer) stream) + (when (minusp value) + (write-char #\- stream)) + (quaviver:write-digits base (abs value) stream + :digit-grouping (decimal-grouping client) + :group-marker (group-marker client)) + value) + +(defmethod quaviver:write-number ((client client) (base (eql 16)) (value integer) stream) + (when (minusp value) + (write-char #\- stream)) + (write-string "0x" stream) + (quaviver:write-digits base (abs value) stream + :digit-grouping (hexadecimal-grouping client) + :group-marker (group-marker client)) + value) + +(defmethod quaviver:write-number ((client client) (base (eql 10)) (value float) stream) + (multiple-value-bind (significand exponent sign) + (quaviver:float-integer client base value) + (when (keywordp exponent) + (error "Unable to represent ~a." exponent)) + (when (minusp sign) + (write-char #\- stream)) + (let ((len (quaviver.math:ceiling-log-expt 10 2 (integer-length significand)))) + (cond ((<= (- len) exponent -1) + (quaviver:write-digits base significand stream + :fractional-position (+ len exponent) + :fractional-marker #\. + :digit-grouping (decimal-grouping client) + :group-marker (group-marker client))) + (t + (quaviver:write-digits base significand stream + :digit-grouping (decimal-grouping client) + :group-marker (group-marker client)) + (unless (zerop exponent) + (write-char #\e stream) + (when (minusp exponent) + (write-char #\- stream)) + (quaviver:write-digits base (abs exponent) stream + :digit-grouping (exponent-grouping client) + :group-marker (group-marker client))))))) + value) diff --git a/code/python/packages.lisp b/code/python/packages.lisp new file mode 100644 index 00000000..88603017 --- /dev/null +++ b/code/python/packages.lisp @@ -0,0 +1,5 @@ +(in-package #:common-lisp-user) + +(defpackage #:quaviver/python + (:use #:common-lisp) + (:export #:client)) diff --git a/quaviver.asd b/quaviver.asd index 8601564e..b91715e6 100644 --- a/quaviver.asd +++ b/quaviver.asd @@ -250,6 +250,21 @@ :components ((:file "packages") (:file "implementation"))))) +(defsystem "quaviver/python" + :description "Python Serialization/Deserialization for Quaviver" + :license "MIT" + :author ("Tarn W. Burton") + :version (:read-file-form "version.sexp") + :homepage "https://github.com/s-expressionists/Quaviver" + :bug-tracker "https://github.com/s-expressionists/Quaviver/issues" + :source-control (:git "https://github.com/s-expressionists/Quaviver.git") + :depends-on ("quaviver") + :components ((:module "code" + :pathname "code/python/" + :serial t + :components ((:file "packages") + (:file "implementation"))))) + (defsystem "quaviver/ansi-test" :description "ANSI Test system for Quaviver" :license "MIT" From ddf7cf5abea5b3e29b6ee925fb2de4e0254a41a3 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Wed, 24 Jul 2024 06:45:47 -0400 Subject: [PATCH 13/16] string: new system for utility parse-number, etc. --- code/string/clients.lisp | 54 ++++++++++++++++++++++++++++++ code/string/number-parser.lisp | 60 ++++++++++++++++++++++++++++++++++ code/string/number-writer.lisp | 5 +++ code/string/packages.lisp | 5 +++ quaviver.asd | 24 ++++++++++++++ 5 files changed, 148 insertions(+) create mode 100644 code/string/clients.lisp create mode 100644 code/string/number-parser.lisp create mode 100644 code/string/number-writer.lisp create mode 100644 code/string/packages.lisp diff --git a/code/string/clients.lisp b/code/string/clients.lisp new file mode 100644 index 00000000..26e54f87 --- /dev/null +++ b/code/string/clients.lisp @@ -0,0 +1,54 @@ +(in-package #:quaviver/string) + +(defclass blub-impl (quaviver/blub:client + quaviver/dragonbox:nearest-client + quaviver/liebler:client) + ()) + +(defclass c-impl (quaviver/c:client + quaviver/dragonbox:nearest-client + quaviver/liebler:client) + ()) + +(defclass common-lisp-impl (quaviver/common-lisp:client + quaviver/dragonbox:nearest-client + quaviver/liebler:client) + ()) + +(defclass fortran-impl (quaviver/fortran:client + quaviver/dragonbox:nearest-client + quaviver/liebler:client) + ()) + +(defclass json-impl (quaviver/json:client + quaviver/dragonbox:nearest-client + quaviver/liebler:client) + ()) + +(defclass python-impl (quaviver/python:client + quaviver/dragonbox:nearest-client + quaviver/liebler:client) + ()) + +(defvar *clients* + (list :blub (make-instance 'blub-impl) + :c89 (make-instance 'c-impl :standard :c89) + :c99 (make-instance 'c-impl :standard :c99) + :c11 (make-instance 'c-impl :standard :c11) + :c17 (make-instance 'c-impl :standard :c17) + :c23 (make-instance 'c-impl :standard :c23) + :c++98 (make-instance 'c-impl :standard :c++98) + :c++03 (make-instance 'c-impl :standard :c++03) + :c++11 (make-instance 'c-impl :standard :c++11) + :c++14 (make-instance 'c-impl :standard :c++14) + :c++17 (make-instance 'c-impl :standard :c++17) + :c++20 (make-instance 'c-impl :standard :c++20) + :c++23 (make-instance 'c-impl :standard :c++23) + :c++26 (make-instance 'c-impl :standard :c++26) + :common-lisp (make-instance 'common-lisp-impl + :extended-exponent-sign nil) + :common-lisp/ccl (make-instance 'common-lisp-impl + :extended-exponent-sign t) + :fortran (make-instance 'fortran-impl) + :json (make-instance 'json-impl) + :python (make-instance 'python-impl))) diff --git a/code/string/number-parser.lisp b/code/string/number-parser.lisp new file mode 100644 index 00000000..9efdad1a --- /dev/null +++ b/code/string/number-parser.lisp @@ -0,0 +1,60 @@ +(in-package #:quaviver/string) + +(defun whitespace-char-p (x) + (and (member x '(#\space #\tab #\page #\newline #\return)) + t)) + +(defun parse-number (string + &key (start 0) (end (length string)) (base 10) junk-allowed + ((:integer integerp) t) ((:ratio ratiop) t) ((:float floatp) t) + float-type (style #+ccl :common-lisp/ccl #-ccl :common-lisp) + (whitespace #'whitespace-char-p)) + (flet ((whitespace-or-eof-p (eofp index) + (or (and eofp + (>= index end)) + (and (< index end) + (if (functionp whitespace) + (funcall whitespace (char string index)) + (find (char string index) whitespace)))))) + (tagbody + next + (when (whitespace-or-eof-p nil start) + (incf start) + (go next))) + (multiple-value-bind (value index) + (quaviver:parse-number (getf *clients* style) + base string + start end + integerp ratiop floatp + float-type) + (when (and (not junk-allowed) + (not (whitespace-or-eof-p t index))) + (error 'quaviver.condition:invalid-character-error + :found (char string index))) + (values value index)))) + +(defun read-number (stream + &key (base 10) junk-allowed + ((:integer integerp) t) ((:ratio ratiop) t) ((:float floatp) t) + float-type (style :common-lisp) (whitespace #'whitespace-char-p)) + (flet ((whitespace-or-eof-p (eofp) + (let ((char (peek-char nil stream nil))) + (or (and eofp (null char)) + (and char + (if (functionp whitespace) + (funcall whitespace char) + (find char whitespace))))))) + (tagbody + next + (when (whitespace-or-eof-p nil) + (read-char stream nil) + (go next))) + (let ((value (quaviver:read-number (getf *clients* style) + base stream + integerp ratiop floatp + float-type))) + (when (and (not junk-allowed) + (not (whitespace-or-eof-p t))) + (error 'quaviver.condition:invalid-character-error + :found (peek-char nil stream nil))) + value))) diff --git a/code/string/number-writer.lisp b/code/string/number-writer.lisp new file mode 100644 index 00000000..b48a19f2 --- /dev/null +++ b/code/string/number-writer.lisp @@ -0,0 +1,5 @@ +(in-package #:quaviver/string) + +(defun write-number (value stream + &key (base 10) (style :common-lisp)) + (quaviver:write-number (getf *clients* style) base value stream)) diff --git a/code/string/packages.lisp b/code/string/packages.lisp new file mode 100644 index 00000000..9b2784ee --- /dev/null +++ b/code/string/packages.lisp @@ -0,0 +1,5 @@ +(cl:defpackage #:quaviver/string + (:use #:common-lisp) + (:export #:parse-number + #:read-number + #:write-number)) diff --git a/quaviver.asd b/quaviver.asd index b91715e6..dda69a6e 100644 --- a/quaviver.asd +++ b/quaviver.asd @@ -265,6 +265,30 @@ :components ((:file "packages") (:file "implementation"))))) +(defsystem "quaviver/string" + :description "Serialization/Deserialization for Quaviver" + :license "MIT" + :author ("Tarn W. Burton") + :version (:read-file-form "version.sexp") + :homepage "https://github.com/s-expressionists/Quaviver" + :bug-tracker "https://github.com/s-expressionists/Quaviver/issues" + :source-control (:git "https://github.com/s-expressionists/Quaviver.git") + :depends-on ("quaviver/blub" + "quaviver/c" + "quaviver/common-lisp" + "quaviver/fortran" + "quaviver/json" + "quaviver/python" + "quaviver/dragonbox" + "quaviver/liebler") + :components ((:module "code" + :pathname "code/string/" + :serial t + :components ((:file "packages") + (:file "clients") + (:file "number-parser") + (:file "number-writer"))))) + (defsystem "quaviver/ansi-test" :description "ANSI Test system for Quaviver" :license "MIT" From 5c8e4f9cbbcc3dc311d8ebd124145272a3c0df49 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Mon, 22 Jul 2024 10:31:48 -0400 Subject: [PATCH 14/16] unit-test: new system for unit testing --- code/unit-test/json.lisp | 206 +++++++++++++++++++++++++++++++++++ code/unit-test/packages.lisp | 3 + quaviver.asd | 18 +++ 3 files changed, 227 insertions(+) create mode 100644 code/unit-test/json.lisp create mode 100644 code/unit-test/packages.lisp diff --git a/code/unit-test/json.lisp b/code/unit-test/json.lisp new file mode 100644 index 00000000..21940a3d --- /dev/null +++ b/code/unit-test/json.lisp @@ -0,0 +1,206 @@ +(in-package #:quaviver/unit-test) + +(defclass json-client (quaviver/json:client) ()) + +(defmethod quaviver:integer-float ((client json-client) float-type base significand exponent sign) + (list significand exponent sign)) + +(define-test json + + (define-test json.n_number_++ + (fail (quaviver:parse-number (make-instance 'json-client) 10 "++1234"))) + + (define-test json.n_number_+1 + (fail (quaviver:parse-number (make-instance 'json-client) 10 "+1"))) + + (define-test json.n_number_+Inf + (fail (quaviver:parse-number (make-instance 'json-client) 10 "+Inf"))) + + (define-test json.n_number_-01 + (fail (quaviver:parse-number (make-instance 'json-client) 10 "-01"))) + + (define-test json.n_number_-2. + (fail (quaviver:parse-number (make-instance 'json-client) 10 "-2."))) + + (define-test json.n_number_-NaN + (fail (quaviver:parse-number (make-instance 'json-client) 10 "-NaN"))) + + (define-test json.n_number_.-1 + (fail (quaviver:parse-number (make-instance 'json-client) 10 ".-1"))) + + (define-test json.n_number_.2e-3 + (fail (quaviver:parse-number (make-instance 'json-client) 10 ".2e-3"))) + + (define-test json.n_number_0.3e+ + (fail (quaviver:parse-number (make-instance 'json-client) 10 "0.3e+"))) + + (define-test json.n_number_0.3e + (fail (quaviver:parse-number (make-instance 'json-client) 10 "0.3e"))) + + (define-test json.n_number_0.e1 + (fail (quaviver:parse-number (make-instance 'json-client) 10 "0.e1"))) + + (define-test json.n_number_0_capital_E+ + (fail (quaviver:parse-number (make-instance 'json-client) 10 "0E+"))) + + (define-test json.n_number_0_capital_E + (fail (quaviver:parse-number (make-instance 'json-client) 10 "0E"))) + + (define-test json.n_number_0e+ + (fail (quaviver:parse-number (make-instance 'json-client) 10 "0e+"))) + + (define-test json.n_number_0e + (fail (quaviver:parse-number (make-instance 'json-client) 10 "0e"))) + + (define-test json.n_number_1.0e+ + (fail (quaviver:parse-number (make-instance 'json-client) 10 "1.0e+"))) + + (define-test json.n_number_1.0e- + (fail (quaviver:parse-number (make-instance 'json-client) 10 "1.0e-"))) + + (define-test json.n_number_1.0e + (fail (quaviver:parse-number (make-instance 'json-client) 10 "1.0e"))) + + (define-test json.n_number_1eE2 + (fail (quaviver:parse-number (make-instance 'json-client) 10 "1eE2"))) + + (define-test json.n_number_2.e+3 + (fail (quaviver:parse-number (make-instance 'json-client) 10 "2.e+3"))) + + (define-test json.n_number_2.e-3 + (fail (quaviver:parse-number (make-instance 'json-client) 10 "2.e-3"))) + + (define-test json.n_number_2.e3 + (fail (quaviver:parse-number (make-instance 'json-client) 10 "2.e3"))) + + (define-test json.n_number_9.e+ + (fail (quaviver:parse-number (make-instance 'json-client) 10 "9.e+"))) + + (define-test json.n_number_Inf + (fail (quaviver:parse-number (make-instance 'json-client) 10 "Inf"))) + + (define-test json.n_number_NaN + (fail (quaviver:parse-number (make-instance 'json-client) 10 "NaN"))) + + (define-test json.n_number_infinity + (fail (quaviver:parse-number (make-instance 'json-client) 10 "Infinity"))) + + (define-test json.n_number_invalid+- + (fail (quaviver:parse-number (make-instance 'json-client) 10 "0e+-1"))) + + (define-test json.n_number_minus_infinity + (fail (quaviver:parse-number (make-instance 'json-client) 10 "-Infinity"))) + + (define-test json.n_number_minus_sign_with_trailing_garbage + (fail (quaviver:parse-number (make-instance 'json-client) 10 "-foo"))) + + (define-test json.n_number_minus_space_1 + (fail (quaviver:parse-number (make-instance 'json-client) 10 "- 1"))) + + (define-test json.n_number_neg_int_starting_with_zero + (fail (quaviver:parse-number (make-instance 'json-client) 10 "-012"))) + + (define-test json.n_number_neg_real_without_int_part + (fail (quaviver:parse-number (make-instance 'json-client) 10 "-.123"))) + + (define-test json.n_number_real_garbage_after_e + (fail (quaviver:parse-number (make-instance 'json-client) 10 "1ea"))) + + (define-test json.n_number_real_without_fractional_part + (fail (quaviver:parse-number (make-instance 'json-client) 10 "1."))) + + (define-test json.n_number_starting_with_dot + (fail (quaviver:parse-number (make-instance 'json-client) 10 ".123"))) + + (define-test json.n_number_with_leading_zero + (fail (quaviver:parse-number (make-instance 'json-client) 10 "012"))) + + (define-test json.y_number + (is equalp + (list 123 65 1) + (quaviver:parse-number (make-instance 'json-client) 10 "123e65"))) + + (define-test json.y_number_0e+1 + (is equalp + (list 0 1 1) + (quaviver:parse-number (make-instance 'json-client) 10 "0e+1"))) + + (define-test json.y_number_0e1 + (is equalp + (list 0 1 1) + (quaviver:parse-number (make-instance 'json-client) 10 "0e1"))) + + (define-test json.y_number_double_close_to_zero + (is equalp + (list 1 -78 -1) + (quaviver:parse-number (make-instance 'json-client) 10 "-0.000000000000000000000000000000000000000000000000000000000000000000000000000001 +"))) + + (define-test json.y_number_int_with_exp + (is equalp + (list 20 1 1) + (quaviver:parse-number (make-instance 'json-client) 10 "20e1"))) + + (define-test json.y_number_minus_zero + (is equalp + (list 0 0 -1) + (quaviver:parse-number (make-instance 'json-client) 10 "-0" + 0 2 nil))) + + (define-test json.y_number_negative_int + (is equalp + (list 123 0 -1) + (quaviver:parse-number (make-instance 'json-client) 10 "-123" + 0 4 nil))) + + (define-test json.y_number_negative_one + (is equalp + (list 1 0 -1) + (quaviver:parse-number (make-instance 'json-client) 10 "-1" + 0 2 nil))) + + (define-test json.y_number_real_capital_e + (is equalp + (list 1 22 1) + (quaviver:parse-number (make-instance 'json-client) 10 "1E22"))) + + (define-test json.y_number_real_capital_e_neg_exp + (is equalp + (list 1 -2 1) + (quaviver:parse-number (make-instance 'json-client) 10 "1E-2"))) + + (define-test json.y_number_real_capital_e_pos_exp + (is equalp + (list 1 2 1) + (quaviver:parse-number (make-instance 'json-client) 10 "1E+2"))) + + (define-test json.y_number_real_exponent + (is equalp + (list 123 45 1) + (quaviver:parse-number (make-instance 'json-client) 10 "123e45"))) + + (define-test json.y_number_real_fraction_exponent + (is equalp + (list 123456 75 1) + (quaviver:parse-number (make-instance 'json-client) 10 "123.456e78"))) + + (define-test json.y_number_real_neg_exp + (is equalp + (list 1 -2 1) + (quaviver:parse-number (make-instance 'json-client) 10 "1e-2"))) + + (define-test json.y_number_real_pos_exponent + (is equalp + (list 1 2 1) + (quaviver:parse-number (make-instance 'json-client) 10 "1e+2"))) + + (define-test json.y_number_simple_int + (is equalp + (list 123 0 1) + (quaviver:parse-number (make-instance 'json-client) 10 "123" + 0 3 nil))) + + (define-test json.y_number_simple_real + (is equalp + (list 123456789 -6 1) + (quaviver:parse-number (make-instance 'json-client) 10 "123.456789")))) diff --git a/code/unit-test/packages.lisp b/code/unit-test/packages.lisp new file mode 100644 index 00000000..70bc5f6d --- /dev/null +++ b/code/unit-test/packages.lisp @@ -0,0 +1,3 @@ +(defpackage #:quaviver/unit-test + (:use #:common-lisp #:parachute) + (:export)) diff --git a/quaviver.asd b/quaviver.asd index dda69a6e..4f087872 100644 --- a/quaviver.asd +++ b/quaviver.asd @@ -312,6 +312,24 @@ (:file "test") (:static-file "expected-failures.sexp"))))) +(defsystem "quaviver/unit-test" + :description "Unit Test system for Quaviver" + :license "MIT" + :author ("Tarn W. Burton") + :version (:read-file-form "version.sexp") + :homepage "https://github.com/s-expressionists/Quaviver" + :bug-tracker "https://github.com/s-expressionists/Quaviver/issues" + :source-control (:git "https://github.com/s-expressionists/Quaviver.git") + :depends-on ("parachute" + "quaviver/json") + :perform (asdf:test-op (op c) + (uiop:symbol-call :parachute :test :quaviver/unit-test)) + :components ((:module "code" + :pathname "code/unit-test/" + :serial t + :components ((:file "packages") + (:file "json"))))) + (defsystem "quaviver/benchmark" :description "Benchmark system for Quaviver" :license "MIT" From 6b37544a527438ee24d061d9245cd6919303007c Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Mon, 22 Jul 2024 10:32:19 -0400 Subject: [PATCH 15/16] ci: add unit testing and update branch references --- .github/workflows/test.yml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 7c8510a4..94fd02f6 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -37,19 +37,19 @@ jobs: with: repository: s-expressionists/Incless path: incless - ref: quaviver + ref: quaviver3 - name: Checkout Inravina uses: actions/checkout@v4 with: repository: s-expressionists/Inravina path: inravina - ref: quaviver + ref: quaviver3 - name: Checkout Invistra uses: actions/checkout@v4 with: repository: s-expressionists/Invistra path: invistra - ref: quaviver + ref: quaviver3 - name: Checkout Repository uses: actions/checkout@v4 with: @@ -58,6 +58,9 @@ jobs: run: | make-rc asdf-add + - name: Run Unit Tests + run: | + lisp -i ${{ matrix.lisp }} -e "(defparameter cl-user::*exit-on-test-failures* t)" -e "(ql:quickload :quaviver/unit-test)" -e "(parachute:test :quaviver/unit-test)" - name: Run ANSI Tests run: | lisp -i ${{ matrix.lisp }} -e "(ql:quickload :quaviver/ansi-test)" -e "(quaviver/ansi-test:test :exit t)" From 8547b56fdd2e03cf469287cc1794233bddaca4df Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Wed, 31 Jul 2024 07:29:26 -0400 Subject: [PATCH 16/16] quaviver: add fallbacks when short-float or long-float unavailable --- code/bits-float-form.lisp | 8 ++++++++ code/bits-float.lisp | 8 ++++++++ code/float-bits-form.lisp | 8 ++++++++ code/float-internal-integer-form.lisp | 8 ++++++++ code/integer-float.lisp | 10 ++++++++++ code/internal-integer-float-form.lisp | 8 ++++++++ 6 files changed, 50 insertions(+) diff --git a/code/bits-float-form.lisp b/code/bits-float-form.lisp index 28cf846e..726704bf 100644 --- a/code/bits-float-form.lisp +++ b/code/bits-float-form.lisp @@ -25,6 +25,10 @@ (storage-size 'short-float)))) (coerce (ffi:slot (ffi:foreign-value u) 'value) 'short-float))) +#-quaviver/short-float +(defmethod bits-float-form ((float-type (eql 'short-float)) value) + (bits-float-form 'single-float value)) + (defmethod bits-float-form ((float-type (eql 'single-float)) value) #+abcl `(system:make-single-float ,value) @@ -137,3 +141,7 @@ (ffi:get-slot-value ,m 'long-float/uint128 'u) ,n)) (ffi:get-slot-value ,m 'long-float/uint128 'f))))) + +#-quaviver/long-float +(defmethod bits-float-form ((float-type (eql 'long-float)) value) + (bits-float-form 'double-float value)) diff --git a/code/bits-float.lisp b/code/bits-float.lisp index f377599c..87b45dd0 100644 --- a/code/bits-float.lisp +++ b/code/bits-float.lisp @@ -7,6 +7,10 @@ (defmethod bits-float ((float-type (eql 'short-float)) value) (%bits-float short-float value)) +#-quaviver/short-float +(defmethod bits-float ((float-type (eql 'short-float)) value) + (%bits-float single-float value)) + (defmethod bits-float ((float-type (eql 'single-float)) value) (%bits-float single-float value)) @@ -16,3 +20,7 @@ #+quaviver/long-float (defmethod bits-float ((float-type (eql 'long-float)) value) (%bits-float long-float value)) + +#-quaviver/long-float +(defmethod bits-float ((float-type (eql 'long-float)) value) + (%bits-float double-float value)) diff --git a/code/float-bits-form.lisp b/code/float-bits-form.lisp index a933b5ea..6c424a26 100644 --- a/code/float-bits-form.lisp +++ b/code/float-bits-form.lisp @@ -10,6 +10,10 @@ ,(- (storage-size 'short-float) (storage-size 'single-float))))) +#-quaviver/short-float +(defmethod float-bits-form ((float-type (eql 'short-float)) value) + (float-bits-form 'single-float value)) + (defmethod float-bits-form ((float-type (eql 'single-float)) value) #+abcl `(system:single-float-bits ,value) @@ -115,3 +119,7 @@ (logior (ffi:deref-array ,n '(:array :uint64-t 2) 0) (ash (ffi:deref-array ,n '(:array :uint64-t 2) 1) 64))))))) + +#-quaviver/long-float +(defmethod float-bits-form ((float-type (eql 'long-float)) value) + (float-bits-form 'double-float value)) diff --git a/code/float-internal-integer-form.lisp b/code/float-internal-integer-form.lisp index 4ad3f5d1..eb7e4be0 100644 --- a/code/float-internal-integer-form.lisp +++ b/code/float-internal-integer-form.lisp @@ -72,6 +72,10 @@ (defmethod float-internal-integer-form ((float-type (eql 'short-float)) value) `(float-internal-integer/short-float ,value)) +#-quaviver/short-float +(defmethod float-internal-integer-form ((float-type (eql 'short-float)) value) + `(float-internal-integer/single-float ,value)) + (defmethod float-internal-integer-form ((float-type (eql 'single-float)) value) `(float-internal-integer/single-float ,value)) @@ -82,6 +86,10 @@ (defmethod float-internal-integer-form ((float-type (eql 'long-float)) value) `(float-internal-integer/long-float ,value)) +#-quaviver/long-float +(defmethod float-internal-integer-form ((float-type (eql 'long-float)) value) + `(float-internal-integer/double-float ,value)) + (defmethod float-internal-integer-form (float-type value) (declare (ignore float-type)) `(integer-decode-float ,value)) diff --git a/code/integer-float.lisp b/code/integer-float.lisp index f7987204..5234829e 100644 --- a/code/integer-float.lisp +++ b/code/integer-float.lisp @@ -21,3 +21,13 @@ (client (float-type (eql 'long-float)) (base (eql 2)) significand exponent sign) (declare (ignore client)) (internal-integer-float/long-float significand exponent sign)) + +#-quaviver/short-float +(defmethod integer-float + (client (float-type (eql 'short-float)) base significand exponent sign) + (integer-float client 'single-float base significand exponent sign)) + +#-quaviver/long-float +(defmethod integer-float + (client (float-type (eql 'long-float)) base significand exponent sign) + (integer-float client 'double-float base significand exponent sign)) diff --git a/code/internal-integer-float-form.lisp b/code/internal-integer-float-form.lisp index 1b1f5b8a..adc4030a 100644 --- a/code/internal-integer-float-form.lisp +++ b/code/internal-integer-float-form.lisp @@ -100,6 +100,10 @@ (defmethod internal-integer-float-form ((float-type (eql 'short-float)) significand exponent sign) `(internal-integer-float/short-float ,significand ,exponent ,sign)) +#-quaviver/short-float +(defmethod internal-integer-float-form ((float-type (eql 'short-float)) significand exponent sign) + `(internal-integer-float/single-float ,significand ,exponent ,sign)) + (defmethod internal-integer-float-form ((float-type (eql 'single-float)) significand exponent sign) `(internal-integer-float/single-float ,significand ,exponent ,sign)) @@ -109,3 +113,7 @@ #+quaviver/long-float (defmethod internal-integer-float-form ((float-type (eql 'long-float)) significand exponent sign) `(internal-integer-float/long-float ,significand ,exponent ,sign)) + +#-quaviver/long-float +(defmethod internal-integer-float-form ((float-type (eql 'long-float)) significand exponent sign) + `(internal-integer-float/double-float ,significand ,exponent ,sign))