#lang scheme/base
(require
 scheme/control
 "tools.ss"
 "forth.ss")
(require/provide
 "purrr.ss"
 "pic18/asm.ss"
 "pic18/macro.ss"
 "pic18/const.ss"
 "pic18/parsing-words.ss"
 "pic18/geo.ss" ;; FIXME
 "port/ihex.ss"
 "live.ss"
 )
(provide (all-defined-out))


;; BINARY CODE

;; Byte chunks as used in ihex / interactive upload code. For PIC18,
;; the assembler uses 16 bit words as unit. Here we split that into
;; little endian bytes.

(define (chains->binary-code chain-list)
  (prompt
   (map
    (lambda (c) (binchunk-split c 0 8))
    (or (target-chains->bin chain-list)
        (abort #f)))))


;; CODE STATE

;; What happens at load time can be customized using the
;; 'register-code-hook. What we do here is to assemble the code,
;; collect all the chains and collect consolidated binary code.

;; Next to the prj namespace which contains bindings for procedures
;; and macros, we need to keep track of the free memory space on the
;; target.
(define *pointers* '((code 0) (data 0)))

;; Stacks for assembly code chains and binary code chunks.
(define *chains* '())
(define *bin* '())
(define (all-bin) (apply append (reverse *bin*)))

(define (kill-code!)
  (set! *bin* '())
  (set! *chains* '())) 

(define (assemble-chains chains  . _)
  (let-values
      (((bin pointers) (assemble! chains *pointers*)))
    (set! *pointers* pointers))
  (for ((chain (reverse chains))) (push! *chains* chain))
  (push! *bin* (or (chains->binary-code chains)
                   (error 'no-binary-code))))

;; Marks will only affect the code pointers, not the dictionary. It's
;; a crude hacked-up mechanism.

;; FIXME: make interpretation depend on the value of the pointers:
;; i.e. don't execute code that's beyond the current code mark.

(define *marks* '())
(define (mark) (push! *marks* *pointers*))

(define (empty)
  (define bits 5) ;; 2^5 words in a block
  (define (get x) (cadr (assq x *pointers*)))
  (unless (null? *marks*)
    (set! *pointers* (pop! *marks*)))
  (let ((code (bit-ceil (get 'code) bits))
        (data (get 'data)))
    (set! *pointers*
          `((code ,code)
            (data ,data)))
    ;; (printf "erasing: ")
    (erase-from-block (>>> code bits))))

;; We're the boss, so overwrite all hooks:
(define (asm-on!)
  (register-code-hook (list assemble-chains)))
(asm-on!)


;; IHEX

(define (ihex [bin (all-bin)]
              [port (current-output-port)])
   (write-ihex bin port))

(define (save-ihex filename)
  (with-output-to-file/safe filename ihex)
  (kill-code!)) ;; save transfers from *bin* to file.


;; UPLOAD
(define (commit [bin (all-bin)])
  (unless (null? bin)
    (with-console (lambda () (upload-bytes bin)))
    (kill-code!)))


;; MISC

(define (print-code [chains *chains*]) (print-asm-code chains))
(define asm-off! asm-debug!) ;; see purrr.ss

  



;; Scheme -> Scat + Target commands
(define-syntax-rule (0cmd: command ...)
  (begin
    (snarf as-void (scat) (() (command ...)))
    (substitution-types (target) (0cmd command ...))))

(0cmd: commit print-code mark empty)

(substitutions (target)
 ((ul w) (empty mark load w commit)))


(define prog piklab-prog)

;; FIXME: this should go somewhere else

(loading "pic18")