#lang scheme/base

;; Assembler dictionary.

;; Separate file, because the assembler pattern transformer depends on
;; 'asm-find' to check symbols used in the patterns.

;; FIXME: check if assembler name resolution can be moved to compile
;; time + check if contracts can be used for assembler type checking.


(require
 "decoder.ss"
 "pointers.ss"
 "../tools.ss"
 "../target.ss"
 (lib "match.ss"))

(provide

 ;; assembler registry
 asm-find
 asm-register! asm-find
 dasm-register! dasm-find
 ir-ops
 define-asm
 
 asm?
 make-asm
 asm-prototype

 ;; error handling
 asm-error
 proto->asm-error-handler
 
 ;; asm phase: don't report overflow errors in first phase
 asm-phase


)

(define asm-phase (make-parameter -1))




;; For the imperative algos, use a hash table data structure.
(define get  hash-ref)
(define put! hash-set!)
(define table alist->hash)
(define table->alist hash->alist)


;; error handling
(define asm-error
  (make-parameter
   (lambda a (error 'asm-error-not-in-asm-context))))


;; Assembler error handler. This catches all possible errors that
;; occur inside an assembler function.

(define (proto->asm-error-handler asm arguments)
  (let ((asm-proto (asm-prototype asm)))
    (match-lambda*
     (('overflow type value bits)
      (error 'asm-overflow
             "~a overflow error in ~a at ~a (~a doesnt fit in ~a bits) : ~a"
             type
             (instruction->string (asm-current-instruction))
             (pointer-get 'code)
             value bits
             asm-proto
             )))))



;; --- assembler store ---

;; This maps name -> assembler function returning a list of binary words.

;; Instead of using a local hash table, i'm using the global
;; hierarchical hash table space for easy access.

(define-values
  (struct:asm make-asm-internal asm? asm-ref asm-set!)
  (make-struct-type 'word #f 2 0 #f null #f 0))

(define (make-asm fn [proto #f])
  (make-asm-internal fn proto))

(define (asm-prototype asm)
  (asm-ref asm 1))

(define (asm-debug opcode)
  (lambda args `((,opcode ,@args))))

(define *asm*  (table '()))
(define (asm-register! name fn)
  (put! *asm* name fn))
(define (asm-find name)
  (get *asm* name
       (lambda () (asm-debug name))
       ;; (lambda () #f)
       ))

(define-sr (define-asm (name . formals) . body)
  (asm-register!
   'name
   (make-asm
    (lambda formals . body)
    '(name formals))))

(define-sr (asm! body ...) (begin body ... '()))

;; Built-in directives.
(define-asm (here)         `(,(pointer-get 'code)))
(define-asm (allot-data  n) (asm! (pointer-allot! 'data n)))
(define-asm (allot-code  n) (asm! (pointer-allot! 'code n)))

;; Pseudo ops will pass the pattern-tx.ss check, but return run-time
;; errors when used.
(define (pseudo-op op)
  (lambda _ (error 'asm-pseudo-op "~s" op)))
(define-sr (ir-ops (op . args) ...)
  (begin (define-asm (op . args) (pseudo-op 'op)) ...))


;; (run-asm 'reset)
;; (run-asm 'movlw 1)
;; (run-asm '_goto 1 1)
;; (run-asm 'setf 1 1)


;(define (run-asm name . args)
;  (apply (asm-find name) args))



;; --- disassembler store ---

;; decoder implemented as a binary tree

;; The decoder tree contains opcode->code maps. The default node
;; contains a numeric word quote instruction for both branches.

(define disassemblers (decoder-leaf))

(define (dasm-register! address bits code)
  (decoder-set! decoder-leaf disassemblers
                address bits code))

(define (dasm-find address bits)
  (decoder-get disassemblers address bits))

(define (run-dasm word)
  ((dasm-find word) word 16)) ;; PIC specific