#lang scheme/base

(require
 "../tools.ss"
 scheme/match)
;; Routines for creating PICkit2 command and script assemblers.

(provide interpreter
         interpreter-snd
         interpreter-rcv
         dasm
         (struct-out scr)
         )

;; Patch with genuine snd/rcv
(define interpreter-snd
  (make-parameter
   (lambda (bytes)
     (printf "~a\n" bytes))))
(define interpreter-rcv
  (make-parameter
   (lambda () (make-bytes 64))))

;; SCRIPT COMPILER
(define-struct scr (code))

(define (make-opcode name opcode nin [nout #f])
  (lambda tree-args
    ;; Flatten enables script concatenation for multiple arguments.
    (define (concatenate x)
      (cond
       ((number? x) (list x))
       ((scr? x)    (apply append (map concatenate (scr-code x))))
       (else (error 'not-a-script "~a" x))))
    (define args (concatenate (make-scr tree-args)))
    (define (prefix lst) (cons (length lst) lst))
    (define code
      (cons opcode
            (case nin
              ((255) (prefix args)) ;; variable args, first arg is count
              ((254) (cons (car args) (prefix (cdr args)))) ;; script #, then count
              (else
               (unless (= nin (length args))
                 (error 'invalid-argument "~a" (cons name args)))
               args))))
    (if nout
        (send/reply nout code)  ;; compile + execute
        (make-scr code))))      ;; compile only

(define (print-opcode name opcode nin nout)
  (printf "(~a #x~a ~a~a)\n"
          name (hex->string 2 opcode) nin
          (if nout (format " ~a" nout) "")))

;; Perform simple dasm: only map opcode, don't parse arguments.
;; The script file contains a 'type' byte. #xAA = opcode
(define opcode-table (make-vector 256))
(define (dasm script-hash)
  (display ;; ??
   (string-append
    (format "~a\n\n~a:"
            (bytes->string/utf-8 (hash-ref script-hash 'Comment))
            (hash-ref script-hash 'ScriptName))
    (apply string-append
      (for/list ((val (hash-ref script-hash 'Script)))
        (let ((low (band val #xff))
              (hi  (>>> val 8)))
          (case hi
            ((#xAA) (format "\n\t~a" (vector-ref opcode-table low)))
            ((#xBB) (format " #x~a" (hex->string 2 low)))
            ((#x00) (format " ~a" low))))))
     "\n")))

(define-syntax-rule (interpreter (name opcode . spec) ...)
  (begin
    (begin
      (define name (make-opcode 'name opcode . spec))
      (vector-set! opcode-table opcode 'name))
    ...))
  
;; WIRE PROTOCOL

(define (pack-cmd code)
  (append code
          (build-list (- 64 (length code))
                      (lambda _ #xAD)))) ;; END_OF_BUFFER
(define (unpack-reply nout rx)
  (bytes->list
   (case nout
     ((255) (subbytes rx 1 (+ 1 (bytes-ref rx 0)))) ;; length-prefixed
     (else (subbytes rx 0 nout)))))                 ;; fixed size

(define (send/reply nout code)
  ((interpreter-snd) (apply bytes (pack-cmd code)))
  (if (zero? nout)
      '()
      (unpack-reply nout ((interpreter-rcv)))))