;; INSTRUCTION SET TABLE PARSER
;; This code parses an instruction set table to a table with entries:
;;
;;   (name (a1 a2 ...) (opcode . bits) (a1' . bits1) (a2' . bits2) ...
;;
;; where name          symbolic opcode name
;;       a1, a2, ...   formal parameter names in their proper order
;;       opcode, bits  binary opcode and size
;;       a1', a2' ...  formal parameters ordered as they appear in
;;                     the instruction set, with bitfield width

;; The formal parameters are single letters, and their name is
;; associated to certain types:

;; lower case:  unsigned value

;; upper case:  signed value  (overflow truncates)
;;   R          relative jump (overflow throws error)



#lang scheme/base


(require
 (lib "match.ss")
 "../tools.ss"
 ;; "tools.ss"
 (for-template
  scheme/base
  (lib "match.ss")
  "dictionary.ss"
  "tools.ss"))

(provide
 (all-defined-out))



;; OPCODE PROTOTYPE PARSING

;; Implement the function 'binary->proto' which computes the following map:

(define (char->atom char)
  ((lambda (string)
     (or (string->number string)
         (string->symbol string)))
   (string char)))

(define (valid-char? char)
  (not (equal? char #\space)))

;; (bitstring->list "0101 kkkk ffff ffff")
(define (bitstring->list str)
  (map
   char->atom
   (filter valid-char?
           (string->list str))))

;; convert a binary list to number
;; (bin->number '(1 1 0 0))
(define (bin->number lst)
  (foldl (lambda (digit rest)
           (+ digit (* 2 rest))) 0 lst))

;; combine a list as
;; ((k . 1) (k . 1) ... (l . 1) ...) -> ((k . n) (l . m) ...)
;; (combine-bits '((k . 1) (k . 1) (k . 1)))
(define (combine-bits lst)
  (match lst
         (((k . n) (l . m) . rest)
          (if (eq? k l)
              (combine-bits `((,k . ,(+ m n)) ,@rest))
              `((,k . ,n) ,@(combine-bits `((,l . ,m) . ,rest)))))
         (other other)))


;; (split-opcode '(1 0 1 0 k k k k))
;; split opcode and argument list
(define (split-opcode lst)
  ;; assume they are not interleaved
  (let ((opcode    (filter number? lst))
        (arguments (map
                    (lambda (sym) (cons sym 1))
                    (filter symbol? lst))))
    (cons
     (cons (bin->number opcode) (length opcode))
     (combine-bits arguments))))


;; (parse-opcode-proto "0101 kkkk ffff ffff")
(define (parse-opcode-proto str)
  (split-opcode
   (bitstring->list str)))


;; transform a single opcode specification into
;; (name proto (opcode ...))
;; (binary->proto '(xorwf (f d a) "0001 10da ffff ffff"))
;; (binary->proto '(call (n s) "1110 110s kkkk kkkk" "1111 kkkk kkkk kkkk"))
(define (binary->proto row)
  (match row
         ((name proto . binary)
          (append (list name proto)
                  (map parse-opcode-proto binary)))))

(check-set-mode! 'report-failed)
(check (binary->proto '(xorwf (f d a) "0001 10da ffff ffff"))
       => '(xorwf (f d a) ((6 . 6) (d . 1) (a . 1) (f . 8))))



;; ASSEMBLER GENERATOR

;; Determine field assembler in terms of parameter class. This will
;; probably be more elaborate later.
(define (paramclass->asm name)
  (case name
    ((R)  'pc-relative) ;; used for relative jumps
    (else 'ignore-overflow)))

;; (assembler-body '((118 . 7) (s . 1) (k . 8)))
(define (assembler-body opcode-body)
  (foldl (match-lambda*
          (((param . bits) rest)
           `(,(paramclass->asm param)
             ,param ,bits ,rest)))
         (caar opcode-body) ;; inital is opcode (don't need nb bits here)
         (cdr opcode-body)))


;; Create an assembler body with dynamicly bound error handler.

;; FIXME: maybe this is ok, but hiding the prototype in the error
;; handler makes debug inspection difficult. Maybe an assembler
;; should be wrapped in a word structure, or something alike, to
;; allow for a more direct retrieval of debug info?


(define (proto->assembler . proto)
  (match proto
         ((name formals . operands)
          #`(make-asm
             (lambda #,formals
               (list #,@(map assembler-body operands)))
             '#,proto))))

;; DISASSEMBLER GENERATOR

;; (proto->disassembler 'plus '(a b) '((6 . 8) (a . 4) (b . 4)))
;; take only the first binary word (the rest is nops...)

;; FIXME: this is a bit convoluted (and probably PIC specific due to
;; the lack of addressing modes?)

(define (proto->disassembler name formals . binary-words)
  (if (null? (cdar binary-words)) ;; first word has 0 args
      #`(lambda (opcode)
          '(#,name))
      
      #`(lambda (opcode)
          (match
           (cadr
            (chain ;; construct a chain of argument shifts
             `(,opcode ())
             #,@(map
                 (match-lambda
                  ((param . bits)
                   #`(dasm-step '#,param #,bits)))  ;; one shift tick
                 (reverse (cdr (car binary-words))))))
           (#,(map car
                   (cdr (car binary-words)))
            (list '#,name #,@formals))))))


;; ENTRY POINT

(define (instruction-set-tx asm! dasm! instructions)
  (let ((protos
         (map
          binary->proto
          (syntax->datum instructions))))
    
    #`(begin
        #,@(map
            (lambda (proto)
              (match proto
                     ((name formals ((opc1 . bits) . args) . opcn)
                      #`(begin
                          (#,asm!
                           '#,name
                           #,(apply proto->assembler proto))
                          (#,dasm!
                           #,opc1 #,bits  ;; only use first opcode
                           #,(apply proto->disassembler proto))
                          ))))
            protos))))