while'd version of u8vector-append replaced back with tail recursion version

[mot-flash.git] / common.scm

(display "Loading flash iface client...")
(newline)

(use-modules (srfi srfi-1) (ice-9 format) (ice-9 rw))

(define STX-s  (string #\stx))
(define RS-s  (string #\rs))
(define ETX-s  (string #\etx))

(define STX-i (char->integer #\stx))
(define RS-i (char->integer #\rs))
(define ETX-i (char->integer #\etx))

(define STX-u8v (make-u8vector 1 STX-i))
(define RS-u8v (make-u8vector 1 RS-i))
(define ETX-u8v (make-u8vector 1 ETX-i))

(define SENDBUF-SIZE 2048)

(define (list-ref-with-default lst n def)
  (if (< n (length lst))
    (list-ref lst n)
    def)
  )

(define (string->u8vector s)
  (let ((result (make-u8vector (string-length s))))
    (array-map! result char->integer s)
    result)
  )

(define (u8vector->string v)
  (let ((result (make-string (u8vector-length v))))
    (array-map! result integer->char v)
    result)
  )

(define (integer->u8vector i)
  (make-u8vector 1 i)
  )

(define (char->u8vector c)
  (integer->u8vector (char->integer c))
  )

;(define (uniform-vector-append! dst . srcs)
;  (define dst-len (uniform-vector-length dst))
;  (define (do-uniform-vector-append!)
;    (let ((new-index 0)
;         (rest srcs))
;      (while (and (not (null? rest)) (< new-index dst-len))
;            (let ((current-item (car rest))
;                  (current-length (uniform-vector-length (car rest))))
;              (uniform-vector-move! current-item 0 (min current-length (- dst-len new-index)) dst new-index)
;              (set! new-index (+ new-index current-length))
;              )
;            (set! rest (cdr rest))
;            )
;      )
;    )
;  (do-uniform-vector-append!)
;  )

(define (uniform-vector-append! dst . srcs)
  (define dst-len (uniform-vector-length dst))
  (define (do-uniform-vector-append! new-index rest)
    (if (and (not (null? rest)) (< new-index dst-len))
      (let ((current-item (car rest))
            (current-length (uniform-vector-length (car rest))))
        (uniform-vector-move! current-item 0 (min current-length (- dst-len new-index)) dst new-index)
        (do-uniform-vector-append! (+ new-index current-length) (cdr rest)))
      )
    )
  (do-uniform-vector-append! 0 srcs)
  )

(define (u8vector-append . srcs)
  (let ((res (make-u8vector (fold (lambda (v1 sum) (+ (uniform-vector-length v1) sum)) 0 srcs))))
    (apply uniform-vector-append! (cons res srcs))
    res
    )
  )

(define (parse-command cmd)
  (define cmd-len (u8vector-length cmd))
  (define (find-rs-idx idx)
    (if (< idx cmd-len)
      (if (equal? RS-i (u8vector-ref cmd idx))
        idx
        (find-rs-idx (1+ idx)))
      #f)
    )
  (define (sub-vector v s cnt)
    (make-shared-array v (lambda (i) (cons (+ s i) '())) cnt)
    )

  (if (and (equal? (u8vector-ref cmd 0) STX-i) (equal? (u8vector-ref cmd (1- cmd-len)) ETX-i))
    (let ((rs-idx (find-rs-idx 0)))
      (if (equal? rs-idx #f)
        (cons (u8vector->string (sub-vector cmd 1 (- cmd-len 2))) '())
        (cons (u8vector->string (sub-vector cmd 1 (1- rs-idx))) (sub-vector cmd (1+ rs-idx) (- cmd-len (1+ rs-idx) 1)))))
      (throw 'protocol-error "invalid phone answer"))
  )

(define (create-command cmd . args)
  (let ((par (list-ref-with-default args 0 #f)))
    (u8vector-append STX-u8v (string->u8vector cmd)
                     (if (eq? par #f)
                       #u8()
                       (u8vector-append RS-u8v par)
                       )
                     ETX-u8v
                     )
    )
  )


(define (checksum lst)
  (modulo (fold (lambda (c sum) (+ sum c)) 0 lst)
          256)
  )
(define (checksum-u8vector v)
  (checksum (u8vector->list v))
  )

(define (checksum-string s)
  (checksum (map char->integer (string->list s)))
  )

(define (addr-with-checksum addr)
  (let ((str-addr (format #f "~:@(~8,'0X~)" addr)))
    (format #f "~:@(~A~2,'0X~)" str-addr (checksum-string str-addr))
    )
  )

(define (create-addr-command addr)
  (create-command "ADDR" (string->u8vector (addr-with-checksum addr)))
  )

(define (create-jump-command addr)
  (create-command "JUMP" (string->u8vector (addr-with-checksum addr)))
  )

(define (create-bin-command block size)
  (create-command "BIN" (u8vector-append
                          (list->u8vector (map (lambda (fun) (fun size 256)) (list quotient remainder)))
                          block
                          (integer->u8vector (checksum-u8vector block))
                          )
                  )
  )

(define (send-recv-command iface cmd)
  (begin
    (write-flash-iface iface cmd)
    (read-flash-iface iface)
    )
  )

(define (send-block iface block size addr)
  (begin
    (send-recv-command iface (create-addr-command addr))
    (send-recv-command iface (create-bin-command (make-shared-array block list size) size))
   )
)


(define (send-data-from-port iface addr)
  (define (do-send-data-from-port addr buf)
    (let ((ret (uniform-vector-read! buf)))
      (if (or (equal? ret 0) (equal? ret #f))
        addr
        (begin
          (send-block iface buf ret addr)
          (do-send-data-from-port (+ addr ret) buf)
          )
        )
      )
    )
  (- (do-send-data-from-port addr (make-u8vector SENDBUF-SIZE)) addr)
  )

(define (send-loader-from-port iface addr jaddr)
  (begin
    (send-data-from-port iface addr)
    (send-recv-command iface (create-jump-command jaddr))
    )
  )

(define (send-loader-from-file iface fname addr jaddr)
  (with-input-from-file fname (lambda () (send-loader-from-port iface addr jaddr)))
  )

(display "Done.")
(newline)