Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

* unicly-bit-vectors.lisp (uuid-bit-vector-128-to-byte-array): New Fu…

…nction.

* unicly-types.lisp (uuid-bit-vector-valid-bit-offset): New Type.
  (uuid-bit-vector-valid-bit-width): New Type.

* unicly-macros.lisp (def-uuid-request-integer-bit-vector): New Macro.

* unicly-bit-vectors.lisp:
 (uuid-bit-vector-build-offsets): New Function.
 (uuid-from-bit-vector): New Function.
 New Functions: `%uuid_time-low-request-bit-vector',
`%uuid_time-mid-request-bit-vector',
`%uuid_time-high-and-version-request-bit-vector',
`%uuid_clock-seq-and-reserved-request-bit-vector',
`%uuid_clock-seq-low-request-bit-vector', `%uuid_node-request-bit-vector'

* unicly-integers.lisp (uuid-assemble-ub48): New Function.
  (uuid-assemble-ub32): New Function.
  (uuid-assemble-ub16): New Function.
  • Loading branch information...
commit 53cb230068949e00a3b966b3829392b0602d127e 1 parent 87c3853
@mon-key authored
View
31 README
@@ -529,6 +529,37 @@ UNICLY> (equalp
(uuid-get-namespace-bytes (make-v5-uuid *unique-random-namespace* "NOT-A-BUBBA")))
;=> NIL
+
+UNICLY> (make-v5-uuid *uuid-namespace-dns* "bubba")
+;=> eea1105e-3681-5117-99b6-7b2b5fe1f3c7
+
+Roundtripping UUID representations:
+ uuid -> bit-vector -> uuid -> byte-array -> bit-vector -> uuid
+ -> uuid-to-byte-array -> uuid -> uuid-string-36 -> uuid
+
+UNICLY> (make-uuid-from-string
+ (uuid-princ-to-string
+ (uuid-from-byte-array
+ (uuid-to-byte-array
+ (uuid-from-bit-vector
+ (uuid-byte-array-to-bit-vector
+ (uuid-to-byte-array
+ (uuid-from-bit-vector
+ (uuid-to-bit-vector
+ (make-v5-uuid *uuid-namespace-dns* "bubba"))))))))))
+;=> eea1105e-3681-5117-99b6-7b2b5fe1f3c7
+
+UNICLY> (let* ((uuid-1 (make-v5-uuid *uuid-namespace-dns* "bubba"))
+ (uuid-1-bv (uuid-to-bit-vector (make-v5-uuid *uuid-namespace-dns* "bubba")))
+ (uuid-2 (uuid-from-bit-vector uuid-1-bv)))
+ (list :uuid-eql (uuid-eql uuid-1 uuid-2)
+ :eq (eq uuid-1 uuid-2)
+ :eql (eql uuid-1 uuid-2)
+ :equal (equal uuid-1 uuid-2)
+ :equalp (equalp uuid-1 uuid-2)
+ :sxhash (list (sxhash uuid-1) (sxhash uuid-2))))
+;=> (:UUID-EQL T :EQ NIL :EQL NIL :EQUAL NIL :EQUALP NIL :SXHASH (121011444 363948070))
+
UNICLY> (uuid-version-uuid *unique-random-namespace*)
;=> 4
View
14 package.lisp
@@ -75,6 +75,8 @@
#:uuid-bit-vector-16-length ; SIMPLE-TYPE
#:uuid-bit-vector-8-length ; SIMPLE-TYPE
#:uuid-bit-vector-valid-length ; SIMPLE-TYPE
+ ;; #:uuid-bit-vector-valid-bit-offset
+ ;; #:uuid-bit-vector-valid-bit-width ; SIMPLE-TYPE
;; #:uuid-simple-vector-5 : COMPLEX-TYPE
#:uuid-byte-array-16 ; COMPLEX-TYPE
#:uuid-byte-array-20 ; COMPLEX-TYPE
@@ -161,6 +163,9 @@
;; #:uuid-disassemble-ub48
;; #:uuid-disassemble-ub32
;; #:uuid-disassemble-ub16
+ ;; #:uuid-assemble-ub48
+ ;; #:uuid-assemble-ub32
+ ;; #:uuid-assemble-ub16
;;
;; unicly/unicly-bit-vectors.lisp
;;
@@ -170,6 +175,13 @@
;; #:uuid-bit-vector-16-zeroed
;; #:uuid-bit-vector-8-zeroed
;;
+ ;; #:%uuid_time-low-request-bit-vector
+ ;; #:%uuid_time-mid-request-bit-vector
+ ;; #:%uuid_time-high-and-version-request-bit-vector
+ ;; #:%uuid_clock-seq-and-reserved-request-bit-vector
+ ;; #:%uuid_clock-seq-low-request-bit-vector
+ ;; #:%uuid_node-request-bit-vector
+ ;;
;; #:%uuid-version-bit-vector-if
;; #:uuid-version-bit-vector
#:uuid-bit-vector-v3-p
@@ -179,12 +191,14 @@
;; #:uuid-octet-to-bit-vector-8
;; #:uuid-bit-vector-to-integer
;; #:uuid-integer-128-to-bit-vector
+ ;; #:uuid-bit-vector-128-to-byte-array
#:uuid-deposit-octet-to-bit-vector
#:uuid-byte-array-to-bit-vector
;;
#:uuid-bit-vector-eql
#:uuid-bit-vector-null-p
;;
+ #:uuid-from-bit-vector
#:uuid-to-bit-vector
;;
;; unicly/unicly-byte-arrays.lisp
View
222 unicly-bit-vectors.lisp
@@ -62,6 +62,20 @@
;; four hundred thirty-one billion seven hundred sixty-eight million two hundred
;; eleven thousand four hundred fifty-five
;;
+;; The octet offsets into a uuid-bit-vector-128:
+;; (loop
+;; for x from 0 below 128 by 8
+;; for q = 0 then x
+;; as y = 7 then (+ x 7)
+;; collect (list q y))
+;; => ((0 7) (8 15) (16 23) (24 31) ;; %uuid_time-low
+;; (32 39) (40 47) ;; %uuid_time-mid
+;; (48 55) (56 63) ;; %uuid_time-high-and-version
+;; (64 71) ;; %uuid_clock-seq-and-reserved
+;; (72 79) ;; %uuid_clock-seq-low
+;; (80 87) (88 95) (96 103)
+;; (104 111) (112 119) (120 127)) ;; %uuid_nodede
+;;
;;; ==============================
@@ -100,11 +114,11 @@
;; (uuid-bit-vector-eql (uuid-bit-vector-128-zeroed) "bubba")
(defun uuid-bit-vector-eql (uuid-bv-a uuid-bv-b)
(declare
- ;; :NOTE safety 2 required if we want to ensure Python sniffs around for bv length
- ;; So we added `uuid-bit-vector-128-check-type' -- should be no way for it to fail.
- (inline uuid-bit-vector-128-check-type)
- ;; (optimize (speed 3) (safety 2)))
- (optimize (speed 3)))
+ ;; :NOTE safety 2 required if we want to ensure Python sniffs around for bv length
+ ;; So we added `uuid-bit-vector-128-check-type' -- should be no way for it to fail.
+ (inline uuid-bit-vector-128-check-type)
+ ;; (optimize (speed 3) (safety 2)))
+ (optimize (speed 3)))
(uuid-bit-vector-128-check-type uuid-bv-a)
(uuid-bit-vector-128-check-type uuid-bv-b)
(locally
@@ -174,6 +188,59 @@
do (uuid-deposit-octet-to-bit-vector byte offset uuid-bv128)
finally (return (the uuid-bit-vector-128 uuid-bv128)))))
+;; "Convert UUID-BV-128 to a UUID-BYTE-ARRAY-16.
+;; Arg UUID-BV-128 should satisfy `uuid-bit-vector-128-check-type'.
+;; :EXAMPLE
+;; (equalp
+;; (uuid-bit-vector-128-to-byte-array (uuid-to-bit-vector (make-v5-uuid *uuid-namespace-dns* "bubba")))
+;; (uuid-to-byte-array (make-v5-uuid *uuid-namespace-dns* "bubba")))
+(defun uuid-bit-vector-128-to-byte-array (uuid-bv-128)
+ (declare (uuid-bit-vector-128 uuid-bv-128)
+ (optimize (speed 3)))
+ (uuid-bit-vector-128-check-type uuid-bv-128)
+ (when (uuid-bit-vector-null-p uuid-bv-128)
+ (return-from uuid-bit-vector-128-to-byte-array (the uuid-byte-array-16 (uuid-byte-array-16-zeroed))))
+ (labels ((displaced-8 (disp-off)
+ (declare (optimize (speed 3)))
+ (the (bit-vector 8)
+ (make-array 8
+ :element-type 'bit
+ :displaced-to uuid-bv-128
+ :displaced-index-offset disp-off)))
+ ;; ,----
+ ;; | If `make-array' is called with ADJUSTABLE, FILL-POINTER, and
+ ;; | DISPLACED-TO each ‘nil’, then the result is a simple array. If
+ ;; | ‘make-array’ is called with one or more of ADJUSTABLE, FILL-POINTER, or
+ ;; | DISPLACED-TO being true, whether the resulting array is a simple array
+ ;; | is implementation-dependent.
+ ;; `----
+ ;; On SBCL bv8 is of type:
+ ;; (and (bit-vector 8) (not simple-array))
+ (bv8-to-ub8 (bv8)
+ (declare ((bit-vector 8) bv8)
+ (optimize (speed 3)))
+ (let ((j 0))
+ (declare (uuid-ub8 j))
+ (dotimes (i 8 (the uuid-ub8 j))
+ (setf j (logior (bit bv8 i) (ash j 1))))))
+ (get-bv-octets ()
+ (let ((rtn (uuid-byte-array-16-zeroed))
+ (offsets (loop
+ with offsets-array = (uuid-byte-array-16-zeroed)
+ for idx from 0 below 16
+ for bv-offset from 0 below 128 by 8
+ do (setf (aref offsets-array idx) bv-offset)
+ finally (return offsets-array))))
+ (declare (uuid-byte-array-16 rtn offsets))
+ (loop
+ for off across offsets
+ for idx from 0 below 16
+ for octet of-type uuid-ub8 = (bv8-to-ub8 (displaced-8 off))
+ do (setf (aref rtn idx) octet)
+ finally (return rtn)))))
+ (the uuid-byte-array-16 (get-bv-octets))))
+
+
;;; ==============================
;; :NOTE Return value has the integer representation: 267678999922476945140730988764022209929
;; (uuid-to-bit-vector (make-v5-uuid *uuid-namespace-dns* "ḻfḉḲíï<òbG¦>GḜîṉí@B3Áû?ḹ<mþḩú'ÁṒ¬&]Ḏ"))
@@ -418,100 +485,65 @@
;; `%uuid_clock-seq-and-reserved', `%uuid_clock-seq-low'
(uuid-bit-vector-8-length (get-bv-8-int))))))
-;;
-;; (defun uuid-bit-vector-get-sub-range (bit-vector offset length)
-;; (declare (uuid-bit-vector bit-vector)
-;; ((uuid-bit-vector-index 128) start length))
-;;
-;; (defun uuid-bit-vector-node-integer (bv)
-;; (uuid-bit-vector-48-to-integer (uuid-bit-vector-get-sub-range <bv> <from> <to>)
-;;
-;; (defun uuid-bit-vector-clock-seq-and-reserved-integer (bv)
-;; (defun uuid-bit-vector-clock-seq-low-integer (bv)
-;; (defun uuid-bit-vector-time-low-integer (bv)
-;; (defun uuid-bit-vector-time-mid-integer (bv)
-;; (defun uuid-bit-vector-time-high-and-version-integer (bv)
-;;
+;; :NOTE before `def-uuid-request-integer-bit-vector' expansion.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun uuid-bit-vector-build-offsets (bit-offset bit-width)
+ (declare (uuid-bit-vector-valid-bit-offset bit-offset)
+ (uuid-bit-vector-valid-bit-width bit-width)
+ (optimize (speed 3) (safety 2)))
+ (loop
+ for x from bit-offset below (+ bit-offset bit-width) by 8
+ for q = bit-offset then x
+ as y = (cons q (+ x 7))
+ collect y))
+)
;;; ==============================
-;; uuid-bit-vector-~A-integer
-;; node
-;; clock-seq-and-reserved
-;; clock-seq-low
-;; time-low
-;; time-mid
-;; time-high-and-version
-;;; ==============================
-
+;; :NOTE `def-uuid-request-integer-bit-vector' defines the following functions:
+(declaim (inline %uuid_time-low-request-bit-vector
+ %uuid_time-mid-request-bit-vector
+ %uuid_time-high-and-version-request-bit-vector
+ %uuid_clock-seq-and-reserved-request-bit-vector
+ %uuid_clock-seq-low-request-bit-vector
+ %uuid_node-request-bit-vector))
;;
-;; (defun uuid-bit-vector-8-to-integer (bv)
-;; (defun uuid-bit-vector-8-to-octet (bv)
-;;
-;; `%uuid_time-mid' `%uuid_time-high-and-version' `uuid-ub16'
-;; (defun uuid-bit-vector-16-range (bv)
-
+(def-uuid-request-integer-bit-vector "time-low" 0 32)
+(def-uuid-request-integer-bit-vector "time-mid" 32 16)
+(def-uuid-request-integer-bit-vector "time-high-and-version" 48 16)
+(def-uuid-request-integer-bit-vector "clock-seq-and-reserved" 64 8)
+(def-uuid-request-integer-bit-vector "clock-seq-low" 72 8)
+(def-uuid-request-integer-bit-vector "node" 80 48)
;;
-;; `%uuid_time-low' `uuid-ub32'
-;; (defun uuid-bit-vector-32-range (bv)
-
-;;
-;; `%uuid_node' `uuid-ub48'
-;; (defun uuid-bit-vector-48-to-integer (bv)
-
-;;
-;; (defun uuid-bit-vector-16-to-octets (bv)
-;; (defun uuid-bit-vector-32-to-octets (bv)
-;; (defun uuid-bit-vector-48-to-octets (bv)
-;; (defun uuid-bit-vector-deposit-octet-to-byte-array (bv)
-;; (defun uuid-bit-vector-to-uuid-byte-array (bv)
-;;
-;; (uuid-bit-vector-to-uuid (bv)
-
-;;; ==============================
-
-;;; ==============================
-;; :TODO uuid-from-bit-vector
-;;
-;; (defun %uuid-from-bit-vector-if (uuid-bit-vector-128)
-;;; (declare (uuid-bit-vector-128 uuid-bit-vector-128))
-;; (let ((bv-version-if (uuid-version-bit-vector uuid-bit-vector-128)))
-;; (ecase bv-version-if
-;; (0 (return-from 'uuid-from-bit-vector (make-instance 'unique-universal-identifier-null)))
-;; (2
-;; (let ((uuid-bit-vector-128 (uuid-to-bit-vector (make-v4-uuid))))
-;; (error 'uuid-simple-error
-;; :format-control
-;; "Arg UUID-BIT-VECTOR-128 is a uuid version 2.~%~@
-;; The function `unicly:make-v2-uuid' is unimplemented.~%~@
-;; got UUID-BIT-VECTOR-128 with subseq [48,63]:~%~T~S~%"
-;; :format-arguments
-;; (list (subseq uuid-bit-vector-128 48 63))))
-;; ((3 4 5) bv-version-if)
-;;
-
-;; (defun uuid-from-bit-vector (uuid-bit-vector-128)
-;;; (declare (uuid-bit-vector-128 uuid-bit-vector-128))
-
-
-;;; ==============================
-;; :SOURCE usenet-legend/io.lisp :WAS `bit-vector-octets'
-;; :TODO Convert this into `uuid-bit-vector-to-byte-array'
-;; (defun bit-vector-octets (bv)
-;; (declare (type simple-bit-vector bv)
-;; (optimize speed))
-;; (let ((octets (make-array (ceiling (length bv) 8)
-;; :element-type 'octet
-;; :initial-element 0)))
-;; (loop for bit across bv
-;; for i from 0 below (length bv)
-;; do (multiple-value-bind (j k)
-;; (floor i 8)
-;; (setf (aref octets j)
-;; (logior (ash bit k) (aref octets j)))))
-;; (values octets
-;; (length bv))))
-;;; ==============================
-
+(defun uuid-from-bit-vector (bit-vector-128)
+ (declare (inline %uuid_time-low-request-bit-vector
+ %uuid_time-mid-request-bit-vector
+ %uuid_time-high-and-version-request-bit-vector
+ %uuid_clock-seq-and-reserved-request-bit-vector
+ %uuid_clock-seq-low-request-bit-vector
+ %uuid_node-request-bit-vector)
+ (uuid-bit-vector-128 bit-vector-128)
+ (optimize (speed 3)))
+ (uuid-bit-vector-128-check-type bit-vector-128)
+ (when (uuid-bit-vector-null-p bit-vector-128)
+ (return-from uuid-from-bit-vector (the unique-universal-identifier (make-null-uuid))))
+ (let ((tl (the uuid-ub32 (%uuid_time-low-request-bit-vector bit-vector-128)))
+ (tm (the uuid-ub16 (%uuid_time-mid-request-bit-vector bit-vector-128)))
+ (thv (the uuid-ub16 (%uuid_time-high-and-version-request-bit-vector bit-vector-128)))
+ (csr (the uuid-ub8 (%uuid_clock-seq-and-reserved-request-bit-vector bit-vector-128)))
+ (csl (the uuid-ub8 (%uuid_clock-seq-low-request-bit-vector bit-vector-128)))
+ (nd (the uuid-ub48 (%uuid_node-request-bit-vector bit-vector-128))))
+ (declare (uuid-ub32 tl)
+ (uuid-ub16 tm thv)
+ (uuid-ub8 csr csl)
+ (uuid-ub48 nd))
+ (the unique-universal-identifier
+ (make-instance 'unique-universal-identifier
+ :%uuid_time-low tl
+ :%uuid_time-mid tm
+ :%uuid_time-high-and-version thv
+ :%uuid_clock-seq-and-reserved csr
+ :%uuid_clock-seq-low csl
+ :%uuid_node nd))))
;;; ==============================
View
56 unicly-byte-arrays.lisp
@@ -35,16 +35,8 @@
%uuid_clock-seq-and-reserved
%uuid_clock-seq-low
(uuid-disassemble-ub48 %uuid_node))))))
-;;
-;; (progn
-;; (defparameter *tt--uuid-v4* (make-v4-uuid))
-;; (unwind-protect
-;; (equalp (uuid-to-byte-array *tt--uuid-v4*)
-;; (uuid-get-namespace-bytes *tt--uuid-v4*))
-;; (unintern '*tt--uuid-v4*)))
-;;
+
;;; ==============================
-;;
;; :NOTE UNICLY:UUID-GET-NAMESPACE-BYTES is equivalent to
;; UUID:UUID-TO-BYTE-ARRAY we provide it here for congruence.
;; :SEE Bottom of file for our variation of the original definition.
@@ -111,7 +103,19 @@
((>= j 16) sum)
(setf sum (+ (aref uuid-ba-16 j) (ash sum 8)))))
+;; :NOTE Following adapted from `ironclad::integer-to-octets'
+;; :SEE :FILE ironclad/src/public-key/public-key.lisp
+(defun uuid-integer-128-to-byte-array (uuid-integer)
+ (let ((octet-vec (make-array 16 :element-type 'uuid-ub8)))
+ (declare (type uuid-byte-array-16 octet-vec))
+ (loop
+ for i from 15 downto 0
+ for index from 0
+ ;; do (setf (aref octet-vec index) (ldb (byte 8 (ash i 3)) uuid-integer))
+ do (setf (aref octet-vec index) (ldb (byte 8 (* i 8)) uuid-integer))
+ finally (return octet-vec))))
+
;;; ==============================
;; :NOTE the weird loop in the return value of the dotimes form is to accomodate
;; situatiosn where the top bits of the class `unique-universal-identifier' are
@@ -135,8 +139,8 @@
;; (unless (null inner-diff)
;; (push inner-diff diff)))))
;;
-;; Now using code adapted from ironclad::integer-to-octets instead.
-;;
+;; :NOTE Now using code adapted from ironclad::integer-to-octets instead.
+;;
;; (defun uuid-integer-128-to-byte-array (uuid-integer)
;; (declare (uuid-ub128 uuid-integer)
;; (optimize (speed 3)))
@@ -163,29 +167,17 @@
;; (ldb (byte 8 0) uuid-integer))
;; (setf (aref ba-out cnt)
;; (ldb (byte 8 chk-byte) uuid-integer))))))
-;;
-;; :NOTE Following adapted from `ironclad::integer-to-octets'
-(defun uuid-integer-128-to-byte-array (uuid-integer)
- (let ((octet-vec (make-array 16 :element-type 'uuid-ub8)))
- (declare (type uuid-byte-array-16 octet-vec))
- (loop
- for i from 15 downto 0
- for index from 0
- ;; do (setf (aref octet-vec index) (ldb (byte 8 (ash i 3)) uuid-integer))
- do (setf (aref octet-vec index) (ldb (byte 8 (* i 8)) uuid-integer))
- finally (return octet-vec))))
-
+;;; ==============================
-;; :SOURCE cl-crypto/source/rsa.lisp
-#+(or)
-(defun num->byte-array (num)
- (let* ((num-bytes (truncate (+ (integer-length num) 7) 8))
- (num-bits (* num-bytes 8))
- (out (make-array num-bytes :element-type '(unsigned-byte 8))))
- (dotimes (i num-bytes)
- (setf (aref out i) (ldb (byte 8 (- num-bits (* (1+ i) 8))) num)))
- out))
+;;; ==============================
+
+;; Local Variables:
+;; indent-tabs-mode: nil
+;; show-trailing-whitespace: t
+;; mode: lisp-interaction
+;; package: unicly
+;; End:
;;; ==============================
View
50 unicly-docs.lisp
@@ -659,6 +659,20 @@ some value satisfies uuid-bit-vector-8-p and if not signals a condition of type
`unicly::def-uuid-type-check-definer'~%~@
:SEE-ALSO `<XREF>'.~%▶▶▶")
+(fundoc 'def-uuid-request-integer-bit-vector
+ "Convenience macro for functions which extract slot values of class `unique-universal-identifier'.~%~@
+:EXAMPLE~%
+ \(macroexpand-1 '\(def-uuid-request-integer-bit-vector \"time-low\" 0 32\)\)~%
+ \(macroexpand-1 '\(def-uuid-request-integer-bit-vector \"time-mid\" 32 16\)\)~%
+ \(macroexpand-1 '\(def-uuid-request-integer-bit-vector \"time-high-and-version\" 48 16\)\)~%
+ \(macroexpand-1 '\(def-uuid-request-integer-bit-vector \"clock-seq-and-reserved\" 64 8\)\)~%
+ \(macroexpand-1 '\(def-uuid-request-integer-bit-vector \"clock-seq-low\" 72 8\)\)~%
+ \(macroexpand-1 '\(def-uuid-request-integer-bit-vector \"node\" 80 48\)\)~%~@
+:SEE-ALSO
+`%uuid_time-low-request-bit-vector', `%uuid_time-mid-request-bit-vector',
+`%uuid_time-high-and-version-request-bit-vector',
+`%uuid_clock-seq-and-reserved-request-bit-vector',
+`%uuid_clock-seq-low-request-bit-vector', `%uuid_node-request-bit-vector'.~%▶▶▶")
;;; ==============================
@@ -927,6 +941,42 @@ U16 is an integer of type `uuid-ub16' corresponding to either the
\(eq \(nth-value 0 \(uuid-disassemble-ub16 13953\)\) 129\)~%~@
:SEE-ALSO `uuid-disassemble-ub48', `uuid-disassemble-ub32', `uuid-disassemble-ub16'.~%▶▶▶")
+(fundoc 'uuid-assemble-ub48
+"Return an integer of type `uuid-ub48' constructed of the uuid-ub8 octets B1, B2, B3, B4, B5, and B6.~%
+ HIGH ---> LOW
+ B1 ... B6~%~@
+:EXAMPLE~%
+ \(let \(\(ub48 #xFFFFFFFFFFFF\)\)
+ \(multiple-value-bind \(b1 b2 b3 b4 b5 b6\) \(uuid-disassemble-ub48 ub48\)
+ \(eql \(uuid-assemble-ub48 b1 b2 b3 b4 b5 b6\) ub48\)\)\)~%~@
+:SEE-ALSO `uuid-assemble-ub32', `uuid-assemble-ub16',
+`uuid-disassemble-ub48', `uuid-disassemble-ub32', `uuid-disassemble-ub16',
+`uuid-request-integer', `uuid-byte-array-16-to-integer'.~%▶▶▶")
+
+(fundoc 'uuid-assemble-ub32
+"Return an integer of type `uuid-ub32' constructed of the uuid-ub8 octets B1, B2, B3, and B4.~%
+ HIGH ---> LOW
+ B1 ... B4~%~@
+:EXAMPLE~%
+ \(let \(\(ub32 #xFFFFFFFF\)\)
+ \(multiple-value-bind \(b1 b2 b3 b4\) \(uuid-disassemble-ub32 ub32\)
+ \(eql \(uuid-assemble-ub32 b1 b2 b3 b4\) ub32\)\)\)~%~@
+:SEE-ALSO `uuid-assemble-ub48', `uuid-assemble-ub16',
+`uuid-disassemble-ub48', `uuid-disassemble-ub32', `uuid-disassemble-ub16',
+`uuid-request-integer', `uuid-byte-array-16-to-integer'.~%▶▶▶")
+
+(fundoc 'uuid-assemble-ub16
+"Return an integer of type `uuid-ub48' constructed of the uuid-ub8 octets B1 and B2.~%
+ HIGH ---> LOW
+ B1 ... B6~%~@
+:EXAMPLE~%
+ \(let \(\(ub16 #xFFFF\)\)
+ \(multiple-value-bind \(b1 b2\) \(uuid-disassemble-ub16 ub16\)
+ \(eql \(uuid-assemble-ub16 b1 b2\) ub16\)\)\)~%~@
+:SEE-ALSO `uuid-assemble-ub48', `uuid-assemble-ub32',
+`uuid-disassemble-ub48', `uuid-disassemble-ub32', `uuid-disassemble-ub16',
+`uuid-request-integer', `uuid-byte-array-16-to-integer'.~%▶▶▶")
+
(fundoc 'uuid-get-namespace-bytes
"Convert UUID to a byte-array.~%~@
Arg UUID should be an instance of the UNIQUE-UNIVERSAL-IDENTIFIER class.~%~@
View
49 unicly-integers.lisp
@@ -85,7 +85,9 @@
(values b1 b2 b3 b4 b5 b6))))
;;; ==============================
-;; :SOURCE Zach Beane's usenet-legend/io.lisp :WAS `disassemble-u32'
+;; :SOURCE Zach Beane's usenet-legend/io.lisp
+;; `uuid-disassemble-ub32' :WAS `disassemble-u32'
+;; `uuid-assemble-ub32' :WAS `assemble-u32'
(declaim (inline uuid-disassemble-ub32))
(defun uuid-disassemble-ub32 (u32)
(declare (type uuid-ub32 u32)
@@ -106,23 +108,38 @@
(declare (uuid-ub8 b1 b2))
(values b1 b2)))
-;; (uuid-u48-from-bytes (b5 b4 b3 b2 b1 b0)
-;; (declare optimize
+(declaim (inline uuid-assemble-ub48))
+(defun uuid-assemble-ub48 (b1 b2 b3 b4 b5 b6)
+ (declare (type uuid-ub8 b1 b2 b3 b4 b5 b6)
+ (optimize (speed 3)))
+ (logand #xFFFFFFFFFFFF
+ (logior (ash b1 40)
+ (ash b2 32)
+ (ash b3 24)
+ (ash b4 16)
+ (ash b5 8)
+ (ash b6 0))))
-;;; ==============================
-;; (defun uuid-ub32-from-bytes (b3 b2 b1 b0)
-;; ;; (declare (optimize (speed 3))
-;; ;; (uuid-ub8 b3 b2 b1 b0))
-;; (logxor (ash b3 24)
-;; (ash b2 16)
-;; (ash b1 8)
-;; b0))
+(declaim (inline uuid-assemble-ub32))
+(defun uuid-assemble-ub32 (b1 b2 b3 b4)
+ (declare (type uuid-ub8 b1 b2 b3 b4)
+ (optimize speed))
+ (logand #xFFFFFFFF
+ (logior (ash b1 24)
+ (ash b2 16)
+ (ash b3 8)
+ (ash b4 0))))
-;; (defun uuid-ub16-from-bytes (b1 b0)
-;; (declare (uuid-ub8 b3 b2 b1 b0)
-;; (optimize (speed 3)))
-;; (the uuid-ub16 (logxor (ash b1 8) b0))
-;; (logxor (ash 255 8) 255)
+;; (uuid-disassemble-ub32 #xFFFFFFFF)
+;; 255, 255, 255, 255
+
+;(declare (inline uuid-assemble-ub16))
+(defun uuid-assemble-ub16 (b1 b2)
+ (declare (type uuid-ub8 b1 b2)
+ (optimize (speed 3)))
+ (logand #xFFFF
+ (logior (ash b1 8)
+ (ash b2 0))))
;;; ==============================
View
125 unicly-io.lisp
@@ -65,6 +65,31 @@
(defun uuid-valid-stream-verify-octet-stream-for-input (maybe-input-octet-stream)
(uuid-valid-stream-verify-io-octet-type maybe-input-octet-stream :direction :input))
+
+
+;;; ==============================
+;; :NOTE Following idiom does not suitably catch EOF.
+;; (defun uuid-deserialize-byte-array-bytes (stream-in)
+;; (uuid-valid-stream-verify-octet-stream-for-input stream-in)
+;; (let ((bv-return (uuid-bit-vector-128-zeroed)))
+;; (read-sequence bv-return stream :start 0 :end 127)
+;; bv-return))
+;;
+(defun uuid-deserialize-byte-array-bytes (stream-in)
+ (uuid-valid-stream-verify-octet-stream-for-input stream-in)
+ (loop
+ with ba16 = (uuid-byte-array-16-zeroed)
+ for ba16-idx from 0 below 16
+ for byte-read = (read-byte stream-in nil 'EOF)
+ if (eql byte-read 'EOF)
+ do (error 'end-of-file :stream stream-in)
+ end
+ ;; unless (typep byte-read 'bit) ;; catches new line just prior to EOF...
+ ;; do (error "UUID-DESERIALIZE-BIT-VECTOR-BITS -- CL:READ-BYTE read object not of type CL:BIT~%~Tgot: ~S~%~Ttype-of: ~S~%"
+ ;; byte-read (type-of byte-read))
+ do (setf (aref ba16 ba16-idx) byte-read)
+ finally (return ba16)))
+
;;; ==============================
;; :TODO `deserialize-uuid'...
;; :NOTE Should there be a generic function which dispatches on the UUID's
@@ -87,73 +112,40 @@
;; for byte-idx from 0 below 16
;; do (write-byte (aref ba16 byte-idx) stream))
(write-sequence ba16 stream-out :start 0 :end 16)))
-;; *print-array*
-(defun uuid-deserialize-byte-array-bytes (stream-in)
- (uuid-valid-stream-verify-octet-stream-for-input stream-in)
- ;; :NOTE Following idiom does not suitably catch EOF.
- ;; (let ((bv-return (uuid-bit-vector-128-zeroed)))
- ;; (read-sequence bv-return stream :start 0 :end 127)
- ;; bv-return))
- (loop
- with ba16 = (uuid-byte-array-16-zeroed)
- for ba16-idx from 0 below 16
- for byte-read = (read-byte stream-in nil 'EOF)
- if (eql byte-read 'EOF)
- do (error 'end-of-file :stream stream-in)
- end
- ;; unless (typep byte-read 'bit) ;; catches new line just prior to EOF...
- ;; do (error "UUID-DESERIALIZE-BIT-VECTOR-BITS -- CL:READ-BYTE read object not of type CL:BIT~%~Tgot: ~S~%~Ttype-of: ~S~%"
- ;; byte-read (type-of byte-read))
- do (setf (aref ba16 ba16-idx) byte-read)
- finally (return ba16)))
-
-(defun uuid-serialize-bit-vector-bits (bv-or-uuid stream-out)
- (declare ((or uuid-bit-vector-128 unique-universal-identifier) bv-or-uuid)
- (type stream stream-out))
- (uuid-valid-stream-verify-octet-stream-for-output stream-out)
- (let ((bv-128 (the uuid-bit-vector-128
- (if (unique-universal-identifier-p bv-or-uuid)
- (uuid-to-bit-vector bv-or-uuid)
- bv-or-uuid))))
- (declare (uuid-bit-vector-128 bv-128))
- ;; (loop
- ;; ;; for bit-idx downfrom 127 to 0
- ;; for bit-idx from 0 below 128
- ;; do (write-byte (sbit bv-128 bit-idx) stream-out))
- (write-sequence bv-128 stream-out :start 0 :end 128)))
-;; :TODO Test (subtypep (stream-element-type stream) 'uuid-ub8)
+
+;;; ==============================
;; :TODO Should peek at stream to test if we are at end of file
;; (error 'end-of-file :stream stream)
;; Should check if there are pututatively enough bytes remaining in stream with:
;; (>= (- file-length file-position) 128)
;; This won't be 100% reliable but will at least let us bail early for trivial cases.
;;
-;; (let* ((stream-type (stream-element-type stream))
-;; (stream-subtypep (subtypep stream-type 'uuid-ub8)))
-;; (format t "stream-type: ~S~%stream-subtypep: ~S~%" stream-type stream-subtypep))
+;; :NOTE Following idiom with `cl:read-sequence' does not suitably catch EOF.
+;; (defun uuid-deserialize-bit-vector-bits (stream-in)
+;; (let ((bv-return (uuid-bit-vector-128-zeroed)))
+;; (read-sequence bv-return stream-in :start 0 :end 127)
+;; bv-return))
+;;
+;; :NOTE Following is the equivalent using `cl:do' instead of `cl:loop'
+;; (defun uuid-deserialize-bit-vector-bits (stream-in)
+;; (uuid-valid-stream-verify-octet-stream-for-input stream-in)
+;; (let ((bv (uuid-bit-vector-128-zeroed)))
+;; (do ((code (read-byte s nil 'EOF) (read-byte s nil 'EOF))
+;; (cnt 0 (1+ cnt)))
+;; ((if (or (eql code 'EOF) (> cnt 128 ))
+;; t
+;; (unless (typep code 'bit)
+;; (error "UUID-DESERIALIZE-BIT-VECTOR-BITS -- CL:READ-BYTE read object not of type CL:BIT~%~Tgot: ~S~%~Ttype-of: ~S~%"
+;; code (type-of code))))
+;; (if (= cnt 128)
+;; (uuid-bit-vector-eql w-uuid-bv bv)
+;; ;; (values nil (cons code cnt))))
+;; (error 'end-of-file :stream stream-in)))
+;; (setf (sbit bv cnt) code))))
+;;
(defun uuid-deserialize-bit-vector-bits (stream-in)
(uuid-valid-stream-verify-octet-stream-for-input stream-in)
- ;; :NOTE Following idiom with `cl:read-sequence' does not suitably catch EOF.
- ;; (let ((bv-return (uuid-bit-vector-128-zeroed)))
- ;; (read-sequence bv-return stream :start 0 :end 127)
- ;; bv-return))
- ;;
- ;; Following is the equivalent using `cl:do' instead of `cl:loop'
- ;; (let ((bv (uuid-bit-vector-128-zeroed)))
- ;; (do ((code (read-byte s nil 'EOF) (read-byte s nil 'EOF))
- ;; (cnt 0 (1+ cnt)))
- ;; ((if (or (eql code 'EOF) (> cnt 128 ))
- ;; t
- ;; (unless (typep code 'bit)
- ;; (error "UUID-DESERIALIZE-BIT-VECTOR-BITS -- CL:READ-BYTE read object not of type CL:BIT~%~Tgot: ~S~%~Ttype-of: ~S~%"
- ;; code (type-of code))))
- ;; (if (= cnt 128)
- ;; (uuid-bit-vector-eql w-uuid-bv bv)
- ;; ;; (values nil (cons code cnt))))
- ;; (error 'end-of-file :stream stream-in)))
- ;; (setf (sbit bv cnt) code)))
- ;;
(loop
with bv = (uuid-bit-vector-128-zeroed)
for cnt from 0 below 128
@@ -167,6 +159,22 @@
do (setf (sbit bv cnt) byte-read)
finally (return bv)))
+(defun uuid-serialize-bit-vector-bits (bv-or-uuid stream-out)
+ (declare ((or uuid-bit-vector-128 unique-universal-identifier) bv-or-uuid)
+ (type stream stream-out))
+ (uuid-valid-stream-verify-octet-stream-for-output stream-out)
+ (let ((bv-128 (the uuid-bit-vector-128
+ (if (unique-universal-identifier-p bv-or-uuid)
+ (uuid-to-bit-vector bv-or-uuid)
+ bv-or-uuid))))
+ (declare (uuid-bit-vector-128 bv-128))
+ ;; (loop
+ ;; ;; for bit-idx downfrom 127 to 0
+ ;; for bit-idx from 0 below 128
+ ;; do (write-byte (sbit bv-128 bit-idx) stream-out))
+ (write-sequence bv-128 stream-out :start 0 :end 128)))
+
+
;; (fundoc 'uuid-read-bit-vector-bits
;; Read the bits of a UUID's bit-vector representation from INPUT-PATHNAME return
;; an object of type `uuid-bit-vector-128'.
@@ -185,6 +193,7 @@
:element-type 'uuid-ub8)
(uuid-deserialize-bit-vector-bits bv-in)))
+
;;; ==============================
View
28 unicly-macros.lisp
@@ -114,11 +114,39 @@
(the ,(cdr bv-int-size-and-type)
(make-array (the ,(car bv-int-size-and-type) ,zeroed-size) :element-type 'bit :initial-element 0)))))
;;
+(defmacro def-uuid-request-integer-bit-vector (def-name bit-offset bit-width)
+ (let ((ub-declared-assembler
+ (ecase bit-width
+ (48 (cons 'uuid-assemble-ub48 'uuid-ub48))
+ (32 (cons 'uuid-assemble-ub32 'uuid-ub32))
+ (16 (cons 'uuid-assemble-ub16 'uuid-ub16))
+ ;; :NOTE This winds up creating an inline declartation for `cl:identity'... likely harmless.
+ (8 (cons 'identity 'uuid-ub8))))
+ (bv-offsets (uuid-bit-vector-build-offsets bit-offset bit-width))
+ (bv-request-name
+ (%def-uuid-format-and-intern-symbol "%uuid_~@:(~A~)-request-bit-vector" def-name)))
+ `(defun ,bv-request-name (bit-vector-128)
+ (declare
+ (inline ,(car ub-declared-assembler))
+ (uuid-bit-vector-128 bit-vector-128)
+ (optimize (speed 3)))
+ (uuid-bit-vector-128-check-type bit-vector-128)
+ (loop
+ for (a . b) of-type (uuid-ub8 . uuid-ub8 ) in ',bv-offsets
+ collect (loop
+ with j of-type uuid-ub8 = 0
+ for x from a to b
+ do (setf j (logior (sbit bit-vector-128 x) (ash j 1)))
+ finally (return j)) into bytes
+ finally (return (the ,(cdr ub-declared-assembler)
+ (apply #',(car ub-declared-assembler) bytes)))))))
+;;
;; (defmacro @uuid-bit-vector (bit-vector-type bit-vector index)
;; `(sbit (the ,bit-vector-type ,bit-vector) ,index))
;;
;;; ==============================
+
;;; ==============================
;;; Following macros expanded in :FILE unicly/unicly-class.lisp
View
25 unicly-string-uuid.lisp
@@ -6,9 +6,6 @@
(in-package #:unicly)
;; *package*
-;; (eval-when (:compile-toplevel :load-toplevel :execute)
-;;
-
(declaim (inline uuid-hex-vector-parse-time-low
uuid-hex-vector-parse-time-mid
uuid-hex-vector-parse-time-high-and-version
@@ -22,8 +19,6 @@
(def-indexed-hexstring-integer-parser "CLOCK-SEQ-AND-RESERVED" 3 uuid-hex-string-4 0 2 uuid-ub8)
(def-indexed-hexstring-integer-parser "CLOCK-SEQ-LOW" 3 uuid-hex-string-4 2 4 uuid-ub8)
(def-indexed-hexstring-integer-parser "NODE" 4 uuid-hex-string-12 0 12 uuid-ub48)
-;;
-;; )
;;; ==============================
@@ -94,8 +89,10 @@
:%uuid_clock-seq-low (uuid-hex-vector-parse-clock-seq-low chk-uuid-str)
:%uuid_node (uuid-hex-vector-parse-node chk-uuid-str)))))
-;; (unicly::
-#+nil
+
+;;; ==============================
+
+#+(or)
(defun uuid-string-to-sha1-byte-array (string)
(declare (type string string))
(let ((digester (ironclad:make-digest :sha1)))
@@ -105,7 +102,7 @@
#-sbcl (flexi-streams:string-to-octets string :external-format :UTF-8))
(ironclad:produce-digest digester)))
-#+nil
+#+(or)
(defun uuid-string-to-md5-byte-array (string)
(declare (type string string))
(let ((digester (ironclad:make-digest :MD5)))
@@ -116,7 +113,7 @@
(ironclad:produce-digest digester)))
;; :SOURCE cl-crypto/source/aes16.lisp
-#+nil
+#+(or)
(defun hex-str->bin-array (hex-str)
"Convert a hex string to binary array.
Length of hex string must be mulitple of 2"
@@ -129,6 +126,16 @@ Length of hex string must be mulitple of 2"
:end (* 2 (1+ i)))))
bin))
+;;; ==============================
+
+
+;; Local Variables:
+;; indent-tabs-mode: nil
+;; show-trailing-whitespace: t
+;; mode: lisp-interaction
+;; package: unicly
+;; End:
+
;;; ==============================
;;; EOF
View
12 unicly-types.lisp
@@ -88,6 +88,18 @@
uuid-bit-vector-32-length
uuid-bit-vector-16-length
uuid-bit-vector-8-length))
+;;
+(deftype uuid-bit-vector-valid-bit-offset ()
+ '(member 0 32 48 64 72 80))
+
+;; simple-type ???
+;; (funcall (lambda (x) (declare (uuid-bit-vector-valid-bit-width x) (optimize (speed 3) (safety 2))) x) 18)
+(deftype uuid-bit-vector-valid-bit-width ()
+ '(or
+ uuid-bit-vector-48-length
+ uuid-bit-vector-32-length
+ uuid-bit-vector-16-length
+ uuid-bit-vector-8-length))
;; simple-type
;; (funcall (lambda (x) (declare ((uuid-bit-vector-index 3) x) (optimize (speed 3))) x) 4)
Please sign in to comment.
Something went wrong with that request. Please try again.