;; TETHERED INTERPRETER / COMPILER

;; This file contains only the stateless part of the interactive
;; compiler. the other part is in brood.ss

;; All functions (to be) written in scheme for maximal flexibility,
;; and exported to the prj namespace to be used in simulated on target
;; and explicitly tethered interaction.



(module tethered mzscheme
  (require
   (lib "match.ss")

   "badnop.ss"
   
   "composite.ss"
   "primitive.ss"

   "dict.ss"
   "assembler.ss"
   "binary-utils.ss"

   "interactive.ss" ;; parser stuff

   "io-utils.ss"
   "target.ss"

   "list-utils.ss"
   "tree-utils.ss"
   "debug.ss" ; printf-stack

   )
  (provide (all-defined))

  
  ;; BOOT MONITOR PROTOCOL
  
  (define (tnop)           (out 0))

  ;; data stack access
  (define (>t val)         (out 1) (out (int8 val)) (wait-ack))
  (define (t>)             (out 2) (in))

  ;; sync/async code
  (define (tstart/b addr)  (out 3) (_out addr)) ;; async (*)
  (define (tstart/w addr)  (tstart/b (<<< addr 1)))
  (define (texec/b addr)   (tstart/b addr) (wait-ack)) ;; sync
  (define (texec/w addr)   (texec/b (<<< addr 1)))

  ;; (*) Note that 'start' in interactive.ss uses this. Because the
  ;; Purrr console closes the serial port after every command, running
  ;; 'start' on a word that DOES return an ack byte is ok: the ack byte
  ;; is just ignored.

  
  ;; set ram/flash pointers
  (define (a! addr)        (out 4) (_out addr) (wait-ack))
  (define (f! addr)        (out 5) (_out addr) (wait-ack))
  
  (define (tsync)          (out 6) (wait-ack))  ;; explicit target sync
  (define (cold)           (out 7))             ;; reset target

  ;; These send size for symmetry with the 2 below
  (define (n@a+ n)         (out 8)  (out n))
  (define (n@f+ n)         (out 9)  (out n))
  ;; This send size to make host->target protocol context-free
  (define (n!a+/async n)   (out 10) (out n))
  (define (n!f+/async n)   (out 11) (out n))
  
  (define (chkblk)         (out 12))  ;; check code block
  (define (echorq)         (out 13))  ;; echo request
  (define (ferase/async)   (out 14))  ;; erase current flash block
  (define (fprog/async)    (out 15))  ;; program current flash line

  ;; HUB commands
  (define (client c)       (out 16) (out c))
  (define (hub)            (out 17))

  (define (wait-ack) (in)) ;; ignore

  ;; DATA TRANSFER
  
  (define (byte-split fn)
    (lambda (x)
      (fn (int8 x))
      (fn (int8 (>>> x 8)))))

  (define (byte-join fn)
    (lambda ()
      (let* ((lo (fn))
             (hi (fn)))
        (bior (<<< hi 8) lo))))

  (define _out (byte-split out))
  (define _>t  (byte-split >t))

  (define _in  (byte-join in))
  (define _t>  (byte-join t>))
          
  (define (t@ addr)     (a! addr) (n@a+ 1) (in))

  (define (twrite . vals)
    (n!a+/async (length vals))
    (for-each out vals)
    (wait-ack))

  (define _twrite (byte-split twrite))
  
  (define (t!  val addr) (a! addr) (twrite val))
  (define (_t! val addr) (a! addr) (_twrite val))
  
  ;; Move a list of numbers to/from stack (not bulk transfer). The
  ;; first element in the list is the top of stack, so it can be used
  ;; with 'apply' for simulation.
  
  (define (>tstack lst)
    (for-each >t (reverse lst)))
  (define (tstack> n)
    (for n t>))
  (define (sim nargs stackop)
    (display "(sim)\n") ;; notify it's simulated
    (>tstack
     (apply stackop
            (tstack> nargs))))

  ;; raw stream
  (define (nin>list n)  (for n in))
  (define (_nin>list n) (for n _in))

  ;; length + block
  (define (in>list)   (nin>list (in)))
  (define (in>string) (list->bytes (in>list)))

  ;; wrapped transfer commands (can take 0)
  (define (fbytes n) (unless (zero? n) (n@f+ n)))
  (define (abytes n) (unless (zero? n) (n@a+ n)))
  (define (fwords n) (fbytes (<<< n 1)))
  (define (awords n) (abytes (<<< n 1)))

  ;; create a chunked reader to work around 8 bit target count size.
  (define (chunked size command reader)
    (lambda (n)
      (flatten
       (map
        (lambda (n) (command n) (reader n))
        (number->chunks n size)))))

  ;; transfer functions: n -> list 
  (define abytes>list (chunked #x80 abytes nin>list))
  (define fbytes>list (chunked #x80 fbytes nin>list))
  (define awords>list (chunked #x40 awords _nin>list))
  (define fwords>list (chunked #x40 fwords _nin>list))

  ;; block access
  (define (bf! n) (f! (* 64 n)))
  (define (ba! n) (f! (* 64 n)))
  (define (free-block? b)
    (bf! b)
    (chkblk)
    (= #xff (in)))


  ;; UTILS
  
  
  ;; (word dict -- )IO
  (define (dict-tinterpret word dict)
    (cond
     ((dict-find-code dict word) => texec/w)
     ((dict-find-data dict word) => >t)
     (else (error 'undefined-word "~s" word))))

  (define (stack>list bottom stkptr)
    (let* ((top (t@ stkptr))
           (n   (- top bottom)))
      ;; FIXME: check overflow too
      (when (< n 0)
        (error 'target-stack-underflow "~s" n))
      (a! (add1 bottom)) ;; due to TOP=wreg
      (reverse (abytes>list n))))

  ;; PROGRAMMING
  (define (program) (fprog/async) (wait-ack))
  (define (erase)   (ferase/async) (wait-ack))

  ;; To minimise mistakes, these will all set f. This as opposed to
  ;; the readout, which uses words relative to current position.
  
  (define (erase-block b)
    (bf! b) (erase))

  (define (erase-blocks b n)
    (unless (zero? n)
      (erase-block b)
      (erase-blocks (+ b 1) (- n 1))))

  ;; keep erasing until free block
  (define (erase-cblocks b)
    (if (free-block? b)
        (printf "\n")
        (begin
          (printf "~s " b)
          (erase-block b)
          (erase-cblocks (+ b 1)))))

  (define (erase-from/w addr)
    (erase-cblocks
     (ceiling-block addr 32))) ;; 32 words in a block


  ;; bin is a list of < number | org expression >
  
  (define (upload bin)
    (let ((byte-chunks
           (map
            (lambda (c)
              (chunk-align-bits c 3))
            (map
             (lambda (c)
               (split-chunk c 0 8)) ;; convert words -> bytes
             (bin->chunks bin)))))
      (for-each
       upload-normalized-chunk
       byte-chunks)))

  (define upload-normalized-chunk
    (match-lambda
     ((org bytes)
      (f! org)
      (let ((lines (list->table bytes 8)))
        (for-each 
         (lambda (l)
           (display ".")
           (upload-line l))
         lines)
        (newline)))))

  (define (upload-line bytes)
    (unless (= 8 (length bytes))
      (error 'non-normalized-line "~s" bytes))
    (tsync) ;; make sure target is live
    (n!f+/async 8)
    (for-each
     (lambda (x) (out (int8 x)))
     bytes)
    (wait-ack)
    (program))
    

  
  ;; PRINTING

  ;; print stacks
  (define (psu lst)  (printf-stack lst " ~s"))
  (define (psx lst)  (printf-stack (map byte->string lst) " ~a"))
  (define (pss lst)  (printf-stack (map (signed-converter 8) lst) " ~s"))
  (define (_psx lst) (printf-stack (map word->string lst) " ~a"))
  (define (_pss lst) (printf-stack (map (signed-converter 16) lst) " ~s"))

  ;; print a memory map of the first n kb.
  (define (kb n)
    (define (current-block)
      (if
       (begin
         (chkblk)
         (= #xff (in)))
       ". " "x "))
    (define (print-line)
      (printf
       "~a\n"
       (apply
        string-append
        (for 8 current-block))))

    (bf! 0)
    (let ((lines (* 2 n)))
      (for lines print-line)))
  
      
  
  ;; SNARFS
  
  (snarf as-void (badnop)
    ((a)   (_out >t _>t >tstack
            texec/w texec/b tstart/w tstart/b
            awords abytes fwords fbytes
            a! f! ba! bf!
            n@a+ n@f+
            n!a+/async n!f+/async
            erase-block erase-cblocks erase-from/w
            kb upload
            client))
    ((a b) (t! _t! sim
            erase-blocks
            ))
    (()    (tnop wait-ack tsync cold chkblk echorq
            ferase/async fprog/async program erase hub
            )))

  (snarf as-push (badnop)
    (()    (_in t> _t> in>string in>list))
    ((a)   (t@ tstack> nin>list _nin>list 
            fwords>list fbytes>list abytes>list awords>list
            psu psx pss _psx _pss
            free-block?
            ))
    ((a b) (dict-tinterpret stack>list)))
  




;; transparant cat functions, independent of badnop state. i'm trying
;; to sever the PIC specific part from the more general part, so
;; proper separation later is feasible.

(compositions (badnop) badnop:

 ;; target I/O
 (>byte round #xff and)
 (>hilo dup 8 >>> >byte swap >byte)
 (hilo> swap 8 <<< or)


 ;; support for interactive.ss that has little use in scheme code.
 (tlit        >t)
 (_tlit       _>t)

 (find        swap dict-find)            ;; maybe make this polymorphic
 (find/false  swap dict-find/false)

 


 (@f+       1 n@f+ in)

 (identify  echorq in>string bytes->string/utf-8)
 
 (ping      identify d cr)


 (ps        #x80 xor #x80 - p)
 (_ps       #x8000 xor #x8000 - p)
 
 (px        pbyte)
 (_px       pword)
 (_p        p)
 
 (pbyte     byte->string d)  (h pbyte)
 (pword     word->string d)


 ;; misc wrappers for commands
 (_cold     cold)
 (_ping     ping)

 
 ;; An attempt to do this the smart way: it's easier to always
 ;; transfer unsigned bytes, since they don't need sign
 ;; extension. That's what xxx>list does. However, for plots of
 ;; signals, it's mostly useful to use signed data, so plot will
 ;; convert to signed, and assume the data is in offset binary format.

 (plot      abytes>list (#x80 -) map plot-list)
 (2plot     awords>list (#x8000 -) map plot-list)
            
 
 
 (pfline    4 fwords>list (pword) for-each cr)
 (fdump     8 (pfline) for)

 
 
 ;; 'target-stack' gives (bottom stkptr) for the current target
 (ts>list    target-stack stack>list)
 (_ts>list   ts>list 8 0 join-nibble-list)
 
 (ts   ts>list psu)
 (tsx  ts>list psx)
 (tss  ts>list pss)

 (_ts  _ts>list psu)
 (_tsx _ts>list _psx)
 (_tss _ts>list _pss)


 ;; FIXME: PIC18 specific
 (access-bank dup #x80 and #x80 =
              (#xF00 xor) if)

 
 ;; disassemble one block

 (codeblock 32 fwords>list)

 ;; data mem
 (paline   8 n@a+ 8 (in pbyte) for cr)
 (adump    8 (paline) for)

 (abd      ablock adump)
 (fbd      flock fdump)
 
 ;; slurp and spam
 (slurp    16 (in pbyte) for cr slurp)
 (spam     0 out spam)
 

 ;; code memory check
 (fresh?    chkblk in #xff =)

 ;; round addresses to next block boundary
 (ceil-word->block   1 - -32 and 32 +)
 (ceil-byte->block   1 - -64 and 64 +)




 
;;  ;; upload binary code ( bin -- )
;;  (upload    bin->chunks words->bytes
;;             (3 chunk-align-bits) map
;;             (upload-chunk) for-each)



; (<ab>--ba      uncons car swap)
; (porg          "org" d p cr)


;;  ;; verbose printing
;;  (print-chunk
;;                 <ab>--ba
;;                 porg
;;                 8 list->table
;;                 ((pbyte) for-each cr) for-each)

 

;;  (~upload-line  tsync  ;; make sure target's there
;;                 8 n!f+/async
;;                 (>byte ;; dup pbyte
;;                        out) for-each
;;                 wait-ack
;;                 program ;; cr
;;                 )

;;  (upload-line   dup '() eq? (drop) (~upload-line) ifte)
                

;;  (upload-chunk  <ab>--ba dup f! porg
;;                 8 list->table 
;;                 (upload-line "." display) for-each cr)


 ;; constants + macros
 (macros       '(macro) ns-ls
               (symbol->string d) for-each cr)

                
 ;; printing
 
 ;; (print-dict   (uncons p tab p cr) for-each)
 (print-dict   pp) ;; no nonsense
 (print-words  (car p) for-each cr)

 (print-formatted-asm (format-asm display) for-each)
 
 (print-asm    pretty-asm print-formatted-asm)
 (print-bin    8 list->table 
               ((dup number?
                     (word->string d space)
                     (p) ifte)
                for-each cr)
               for-each)


 ;; file output
 (export-ihex   (print-ihex) swap with-output-to-file/safe)
 (save-tree     (write-tree) swap with-output-to-file/safe)




 )







)