projects
/
rrq
/
lsp-utils.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Simplifying importing with pointer-pointer return.
[rrq/lsp-utils.git]
/
lsp-dbus
/
lsp-dbus-marshal.lsp
diff --git
a/lsp-dbus/lsp-dbus-marshal.lsp
b/lsp-dbus/lsp-dbus-marshal.lsp
index 81b6aa50184d682c66fa267375b3632dac125133..26da795abfcd2cbcafd106bc5b5e86e4510bc165 100644
(file)
--- a/
lsp-dbus/lsp-dbus-marshal.lsp
+++ b/
lsp-dbus/lsp-dbus-marshal.lsp
@@
-15,6
+15,7
@@
; Ex: "a(yi)" = (("a" ("y" "i")))
; Ex: "yyyyuua(yv)" = ("y" "y" "y" "y" "u" "u" ("a" ("y" "v")))
(define (expand-signature S)
; Ex: "a(yi)" = (("a" ("y" "i")))
; Ex: "yyyyuua(yv)" = ("y" "y" "y" "y" "u" "u" ("a" ("y" "v")))
(define (expand-signature S)
+ (setf S (replace "{" (replace "}" (copy S) ")") "("))
(let ((STACK '()) (CUR '()) (A 0))
(dolist (X (explode S))
(case X
(let ((STACK '()) (CUR '()) (A 0))
(dolist (X (explode S))
(case X
@@
-49,7
+50,7
@@
(constant
'FMTMAP ; mapping dbus type code to byte size and newlisp code
'( ("y" 1 "b") ; BYTE (unsigned 8-bit integer)
(constant
'FMTMAP ; mapping dbus type code to byte size and newlisp code
'( ("y" 1 "b") ; BYTE (unsigned 8-bit integer)
- ("b"
1 "b
") ; BOOLEAN (0 is FALSE, 1 is TRUE, else invalid)
+ ("b"
4 "lu
") ; BOOLEAN (0 is FALSE, 1 is TRUE, else invalid)
("n" 2 "d") ; INT16 (signed 16-bit integer)
("q" 2 "u") ; UINT16 (unsigned 16-bit integer)
("i" 4 "ld") ; INT32 (signed 32-bit integer)
("n" 2 "d") ; INT16 (signed 16-bit integer)
("q" 2 "u") ; UINT16 (unsigned 16-bit integer)
("i" 4 "ld") ; INT32 (signed 32-bit integer)
@@
-123,6
+124,7
@@
;; position in DATA. Then advance AT further past that unpacking but
;; return the unpacked value.
(define (unpack-align I FMT)
;; position in DATA. Then advance AT further past that unpacking but
;; return the unpacked value.
(define (unpack-align I FMT)
+ ##(println (list 'unpack-align I FMT AT (length DATA)))
(align-AT I)
(prog1 ((unpack FMT (AT DATA)) 0) (inc AT I)))
(align-AT I)
(prog1 ((unpack FMT (AT DATA)) 0) (inc AT I)))
@@
-144,13
+146,12
@@
;; and followed by a NUL byte. The subsequent data is unpacked
;; according to that type character.
(define (unpack-data-variant)
;; and followed by a NUL byte. The subsequent data is unpacked
;; according to that type character.
(define (unpack-data-variant)
- (let ((ES ((unpack "bs1b" (AT DATA)) 1)))
- (inc AT 3)
- (unpack-data-item ES)))
+ (unpack-data-item ((expand-signature (unpack-data-signature "g")) 0)))
;; Unpack the ES type item from (AT DATA), optionally with
;; pre-alignment, and increment AT past the padding and item.
(define (unpack-data-item ES)
;; Unpack the ES type item from (AT DATA), optionally with
;; pre-alignment, and increment AT past the padding and item.
(define (unpack-data-item ES)
+ ##(println (list 'unpack-data-item ES AT (length DATA)))
(if (list? ES) (unpack-data-struct ES)
(= ES "s") (unpack-data-string ES)
(= ES "o") (unpack-data-string ES)
(if (list? ES) (unpack-data-struct ES)
(= ES "s") (unpack-data-string ES)
(= ES "o") (unpack-data-string ES)
@@
-163,12
+164,15
@@
;; elements.
(define (unpack-data-array ES)
(let ((A AT) (N (+ (unpack-align 4 "u") AT)) (OUT '()))
;; elements.
(define (unpack-data-array ES)
(let ((A AT) (N (+ (unpack-align 4 "u") AT)) (OUT '()))
+ (when (and (list? ES) (!= "a" (ES 0))) (align-AT 8))
(while (< AT N)
(while (< AT N)
+ ##(println "---next " (list AT N))
(push (unpack-data-item ES) OUT -1))
OUT))
;; Unpack a structure or array with ES fields.
(define (unpack-data-struct ES)
(push (unpack-data-item ES) OUT -1))
OUT))
;; Unpack a structure or array with ES fields.
(define (unpack-data-struct ES)
+ ##(println (list 'unpack-data-struct ES AT))
(if (= "a" (ES 0)) (unpack-data-array (ES 1))
(begin (align-AT 8) (map unpack-data-item ES))))
(if (= "a" (ES 0)) (unpack-data-array (ES 1))
(begin (align-AT 8) (map unpack-data-item ES))))
@@
-176,6
+180,7
@@
;; a pair (unpacked pos) of unpacked data and how much data is
;; consumed.
(define (unpack-data SIGN DATA (AT 0))
;; a pair (unpacked pos) of unpacked data and how much data is
;; consumed.
(define (unpack-data SIGN DATA (AT 0))
+ ##(println (format "*** unpack-data %s %d %d" SIGN (length DATA) AT))
(list (unpack-data-item (expand-signature SIGN)) AT))
;; Unpack all dbus messages in the given DATA block. Each message
(list (unpack-data-item (expand-signature SIGN)) AT))
;; Unpack all dbus messages in the given DATA block. Each message
@@
-188,18
+193,29
@@
;; extended with the pair ("" body).
(define (unpack-messages DATA)
(let ((AT 0) (OUT '()) (M nil) (D nil) (S nil))
;; extended with the pair ("" body).
(define (unpack-messages DATA)
(let ((AT 0) (OUT '()) (M nil) (D nil) (S nil))
- (while (and (<
AT
(length DATA))
+ (while (and (<
(+ AT 7)
(length DATA))
(setf M (unpack-data "yyyyuua(yv)" DATA AT)))
(setf AT (M 1))
(setf M (unpack-data "yyyyuua(yv)" DATA AT)))
(setf AT (M 1))
- (setf M (M 0 -1)) ; Drop
- (dotimes (i (length M 0))
+ ##(println "message head " (M 0))
+ ##(println (list 'remains AT (length DATA)))
+ (setf M (M 0 -1)) ; Drop all but the headers then map to symbol keys
+ (dotimes (i (length M))
(setf (M i 0) (MESSAGE-HEADERS (M i 0) 0)))
(setf (M i 0) (MESSAGE-HEADERS (M i 0) 0)))
- (setf S (if (lookup 'SIGNATURE M) ($it 0) ""))
+ ##(println "mapped headers " M)
+ ;; Add the body, if any, keyed by "".
+ (setf S (if (lookup 'SIGNATURE M) $it ""))
+ ##(println (list 'sign S))
(when (and (!= S "") (setf D (unpack-data S DATA AT)))
(setf AT (D 1))
(extend M (list (list "" (D 0)))))
(when (and (!= S "") (setf D (unpack-data S DATA AT)))
(setf AT (D 1))
(extend M (list (list "" (D 0)))))
- (push M OUT -1)
+ ;; Collate message and move to the next portion in DATA
+ (push M OUT -1)
+ ##(println (list 'ending AT (length DATA)))
+ ;;(align-AT 4)
+ ##(println (list 'aligned AT (length DATA)))
(setf DATA (AT DATA))
(setf AT 0)
)
OUT ))
(setf DATA (AT DATA))
(setf AT 0)
)
OUT ))
+
+"lsp-dbus-marshal.lsp"