Address SBCL warnings, add tests for composite types

Author: Symbolics

binary-types.asd

@@ -7,7 +7,7 @@
   :description "A library for reading and writing binary records."
   :long-description #.(uiop:read-file-string
 		       (uiop:subpathname *load-pathname* "description.text"))
-  :version "1.0.0"
+  :version "1.0.1"
   :author "Frode V. Fjeld"
   :maintainer "Steven Nunez"
   :license :BSD-3-Clause

binary-types.lisp

@@ -35,33 +35,6 @@ means that the endianess is determined by the dynamic value of *endian*."
   "*endian* must be (dynamically) bound to either :big-endian or
 :little-endian while reading endian-sensitive types.")
 
-;;; ----------------------------------------------------------------
-;;;                  Binary Types Namespace
-;;; ----------------------------------------------------------------
-
-(defvar *binary-type-namespace* (make-hash-table :test #'eq)
-  "Maps binary type's names (which are symbols) to their binary-type class object.")
-
-(defun find-binary-type (name &optional (errorp t))
-  (or (gethash name *binary-type-namespace*)
-      (if errorp
-	  (error "Unable to find binary type named ~S." name)
-	nil)))
-
-(defun (setf find-binary-type) (value name)
-  (check-type value binary-type)
-  (let ((old-value (find-binary-type name nil)))
-    (when (and old-value (not (eq (class-of value) (class-of old-value))))
-      (warn "Redefining binary-type ~A from ~A to ~A."
-	    name (type-of old-value) (type-of value))))
-  (setf (gethash name *binary-type-namespace*) value))
-
-(defun find-binary-type-name (type)
-  (maphash #'(lambda (key val)
-	       (when (eq type val)
-		 (return-from find-binary-type-name key)))
-	   *binary-type-namespace*))
-
 ;;; ----------------------------------------------------------------
 ;;;                  Base Binary Type (Abstract)
 ;;; ----------------------------------------------------------------
@@ -102,6 +75,33 @@ means that the endianess is determined by the dynamic value of *endian*."
   (print-unreadable-object (object stream :type 'binary-type)
     (format stream "~A" (binary-type-name object))))
 
+;;; ----------------------------------------------------------------
+;;;                  Binary Types Namespace
+;;; ----------------------------------------------------------------
+
+(defvar *binary-type-namespace* (make-hash-table :test #'eq)
+  "Maps binary type's names (which are symbols) to their binary-type class object.")
+
+(defun find-binary-type (name &optional (errorp t))
+  (or (gethash name *binary-type-namespace*)
+      (if errorp
+	  (error "Unable to find binary type named ~S." name)
+	nil)))
+
+(defun (setf find-binary-type) (value name)
+  (check-type value binary-type)
+  (let ((old-value (find-binary-type name nil)))
+    (when (and old-value (not (eq (class-of value) (class-of old-value))))
+      (warn "Redefining binary-type ~A from ~A to ~A."
+	    name (type-of old-value) (type-of value))))
+  (setf (gethash name *binary-type-namespace*) value))
+
+(defun find-binary-type-name (type)
+  (maphash #'(lambda (key val)
+	       (when (eq type val)
+		 (return-from find-binary-type-name key)))
+	   *binary-type-namespace*))
+
 ;;; ----------------------------------------------------------------
 ;;;                      Integer Type (Abstract)
 ;;; ----------------------------------------------------------------
@@ -1042,6 +1042,8 @@ binding is shadowed."
 				      (funcall ,save-brb-var s)))))
        ,@body)))
 
+;; Siebel, and SBCL, warn against this style.  Consider making them
+;; all keyword parameters in the next release.
 (defmacro with-binary-output-to-vector
     ((stream-var &optional (vector-or-size-form 0)
       &key (adjustable (and (integerp vector-or-size-form)
@@ -1153,7 +1155,7 @@ otherwise the value of BODY."
   (check-type size (integer 1 *))
   (check-type endian endianess)
   `(progn
-     (deftype ,name () '(ieee-754 ,(* 8 size)))
+     (deftype ,name () 'float)
      (setf (find-binary-type ',name)
        (make-instance 'binary-float
 	 'name ',name

pkgdcl.lisp

@@ -29,6 +29,7 @@
 	   ;; type defining macros
 	   #:define-unsigned		; [macro] declare an unsigned-int type
 	   #:define-signed		; [macro] declare a signed-int type
+	   #:define-float		; [macro] declare a IEEE-754 float
 	   #:define-binary-struct	; [macro] declare a binary defstruct type
 	   #:define-binary-class	; [macro] declare a binary defclass type
 	   #:define-binary-vector	; [macro] declare a binary vector type

tests/tests.lisp

@@ -294,3 +294,43 @@
   ;; "quad precision" (128-bit) we'll add the tests.
 
 
+
+(deftest composite (binary-types)
+
+  ;; vector of vectors
+  (let* ((binary-types:*endian* :little-endian)
+	 (test-vector #(#(0.9143338203430176d0 0.21972346305847168d0 0.9707512855529785d0 0.5962116718292236d0 0.6005609035491943d0 0.5940588712692261d0 0.2837725877761841d0 0.009566903114318848d0 0.8435225486755371d0 0.22492897510528564d0)
+		       #(0.8314709663391113d0 0.2795267105102539d0 0.5844146013259888d0 0.7568612098693848d0 0.9189847707748413d0 0.007325291633605957d0 0.3114813566207886d0 0.5958571434020996d0 0.07142329216003418d0 0.7225879430770874d0)
+		       #(0.6982585191726685d0 0.42384862899780273d0 0.8679864406585693d0 0.3627190589904785d0 0.3574702739715576d0 0.7974770069122314d0 0.5154801607131958d0 0.4812943935394287d0 0.48626482486724854d0 0.9495172500610352d0)))
+	 binary-to
+	 binary-from)
+
+    (eval `(define-binary-vector bve f64 10)) ;binary vector elements
+    (eval `(define-binary-vector binary-vec bve 3)) ;the outmost vector
+    (setf binary-to (with-output-to-sequence (out)
+		      (write-binary 'binary-vec out test-vector)))
+    (setf binary-from (with-input-from-sequence (in binary-to)
+			(read-binary 'binary-vec in)))
+    (assert-true (num= test-vector binary-from)))
+
+  ;; vector of arrays
+  ;; This really is an optional functionality.  If you need to read vectors of arrays, do it in a loop
+  #+(or)
+  (let* ((binary-types:*endian* :little-endian)
+	 #+nil
+	 (test-vector `#(,(aops:rand '(3 3)) ;a vector of 4 3x3 arrays of single-float
+			 ,(aops:rand '(3 3))
+			 ,(aops:rand '(3 3))
+			 ,(aops:rand '(3 3))))
+	 binary-to
+	 binary-from)
+
+    (eval `(define-binary-array bae f32 '(3 3))) ;binary array elements, a 3x3 array of single-float
+    (eval `(define-binary-vector binary-vec bae 4)) ;vector of 4 'bae
+    (setf binary-to (with-output-to-sequence (out)
+		      (write-binary 'binary-vec out test-vector)))
+    (setf binary-from (with-input-from-sequence (in binary-to)
+			(read-binary 'binary-vec in)))
+    (assert-true (num= test-vector binary-from)))
+
+  )