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





(module asmgen-tx mzscheme
  
  (require (lib "match.ss")
           "list-utils.ss"
           ;; "assembler.ss"
           ;;
           "asmgen-runtime.ss"
           "test.ss")

  (require-for-template mzscheme
                        (lib "match.ss")
                        "asmgen-runtime.ss"
                        ;; "assembler.ss"
                        )

   
  (provide (all-defined))



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

  (define-test (binary->proto)
    (equal?
     (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) 'asm-signed) ;; used for relative jumps
      (else 'asm-ignore-overflow)))
  
  ;; (assembler-body '((118 . 7) (s . 1) (k . 8)))
  (define (assembler-body opcode-body)
    (fold (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)
            #`(lambda args
                (parameterize
                    ((asm-error
                      (proto->asm-error-handler '#,proto args)))
                  (apply
                   (lambda #,formals
                     (list #,@(map assembler-body operands)))
                   args))))))


  ;; 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 '#,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-object->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))))


    

  
  )