#lang scheme/base

;; Compiler state management.

(require
 "../scat.ss"
 "../tools.ss"
 "../target.ss"
 "../asm.ss"
 "../forth.ss"
 "tethered.ss"
 "console.ss"
 "commands.ss"
 "../port/ihex.ss"
 scheme/control)

(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)))
(define (pointers [lst #f])
  (if lst (set! *pointers* lst) *pointers*))

;; Code necessary to rebuild all the macros.
;; FIXME: this only saves the base language
(define macros
  (make-parameter
   '((require (planet zwizwa/staapl/prj/pic18))
     (init-prj)))) ;; (*)

;; (*) An explicit initialization is necessary for the case where the
;; prj/pic18 module is already loaded.

;; 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 (asm-off!)
  (register-code-hook
   (list
    (lambda (chains . _)
      (print-asm-code chains)))))

;; Printing reverses the standard reversed order.
(define (print-asm-code chains)
  (for-each
   (lambda (x)
     (print-target-word x)
     (newline))
   (reverse chains)))


(define (print-code [chains *chains*]) (print-asm-code chains))

;; 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)))