
; simpvir-assembler assembles simpvir symbolic notation (as scheme data)
; into integer bytcodes. e.g.
;    (push 1)
;    (push 2)
;    (add)
; generates the following bytcodes
;    7
;    1
;    7
;    2
;    9

;;; define hash table routines

(define (find-binding name a-list)
  (let
    ((binding (assq name a-list)))
    (if (null? binding)
      '()
      (if binding
        binding
        '()))))

(define (find-value name a-list)
  (let
    ((binding (find-binding name a-list)))
    (if (null? binding)
      '()
      (cadr binding))))

(define (get-hash-index key table-size)
  (if (not (symbol? key))
    0
    (let*
      ((key-string (symbol->string key))
       (key-length (string-length key-string))
       (key-idx (quotient key-length 2))
       (hash-index
         (lambda (n)
           (remainder n table-size))))
      (cond
        ((zero? key-length) 0)
        ((< key-length 2)
          (char->integer (string-ref key-string 0)))
        ((< key-length 3)
          (hash-index
            (*
              (char->integer (string-ref key-string 0))
              (char->integer (string-ref key-string 1)))))
        ((< key-length 4)
          (hash-index
            (*
              (char->integer (string-ref key-string 1))
              (char->integer (string-ref key-string 2)))))
        ((< key-length 5)
          (hash-index
            (*
              (char->integer (string-ref key-string 1))
              (char->integer (string-ref key-string 2))
              (char->integer (string-ref key-string 3)))))
        (else
          (hash-index
            (*
              (char->integer (string-ref key-string key-idx))
              (char->integer (string-ref key-string (+ key-idx 1)))
              (char->integer (string-ref key-string (+ key-idx 2))))))))))

(define (hash-binding table key index)
  (find-binding key (vector-ref table index)))

(define (hash-ref table key)
  (let
    ((binding
      (find-binding
        key
        (vector-ref
          table
          (get-hash-index key
            (vector-length table))))))
    (if (not (null? binding))
      (cadr binding)
      '())))

(define (hash-set! table key value)
  (let*
    ((hash-index (get-hash-index key (vector-length table)))
     (binding (hash-binding table key hash-index)))
    (if (not (null? binding))
      (set-car! (cdr binding) value)
;(begin
;     (vector-set! labels2 hash-index (+ (vector-ref labels2 hash-index) 1))
      (vector-set!
        table
        hash-index
        (cons
          (list key value)
          (vector-ref table hash-index))))))
;)

(define (hash-table-clear! table size)
  (do ((i 0 (+ i 1))) ((= i size))
    (vector-set! table i '()))) 

(define (make-hash-table size)
  (let
    ((table (make-vector size)))
   (hash-table-clear! table size)
    table))

(define (merge left right gt?)
  (cond
   ((null? left) right)
   ((null? right) left)
   ((gt? (car left) (car right))
    (cons (car right)
          (merge left (cdr right) gt?)))
   (else
    (cons (car left)
          (merge (cdr left) right gt?)))))

;;;

(define (take l n gt?)
  (if (zero? n)
    (list)
    (cons (car l)
          (take (cdr l) (- n 1) gt?))))

(define (merge-sort l gt?)
  (let ((half (quotient (length l) 2)))
    (if (zero? half)
      l
      (merge (merge-sort (take      l half gt?) gt?)
             (merge-sort (list-tail l half) gt?)
             gt?))))

(define (compare> x y)
  (> (car x) (car y)))

(define (fill-vec! l vec)
  (if (not (null? l))
    (let
      ((cell (car l)))
      (vector-set! vec (car cell) (cadr cell))
      (fill-vec! (cdr l) vec))))

(define opcodes '(
  (top-level-begin 0)
  (function-proc-begin 1)
  (function-end 2)
  (proc-end 3)
  (frame-offset 4)
  (stack-ref 5)
  (stack-set 6)
  (push 7)
  (pop 8)
  (add 9)
  (sub 10)
  (mul 11)
  (div 12)
  (mod 13)
  (abs 14)
  (negate 15)
  (shl 16)
  (shr 17)
  (bitor 18)
  (bitand 19)
  (bitnot 20)
  (btr 21)
  (bfl 22)
  (br 23)
  (eq 24)
  (lt 25)
  (gt 26)
  (le 27)
  (ge 28)
  (ne 29)
  (not 30)
  (and 31)
  (or 32)
  (call 33)
  (return 34)
  (read-char 35)
  (eof-object? 36)
  (display 37)
  (newline 38)
  (exit 39)
  (write-char 40)
  (brtable 41)
  (stack-ref-n 42)
  (stack-set-n 43)
  (write-string 44)
  (bitxor 45)
)) 

(define labels (make-hash-table 5701))
;(define labels2 (make-vector 5701 0))

(define pc 0)
(define source-assembly-code '())

(define (process-label label)
  (hash-set! labels label pc))

(define (get-label-list l)
  (let*
    ((l2 (merge-sort l compare>))
     (max-value (caar (reverse l2)))
     (vec (make-vector (+ max-value 1))))
    (do ((i 0 (+ i 1))) ((= i (vector-length vec)))
      (vector-set! vec i 0))
    (fill-vec! l2 vec)
    (vector->list vec)))

(define (process-instruction instruction)
  (if (symbol? instruction)
    (process-label instruction)
    (let
      ((opcode (car instruction))
       (operands (cdr instruction)))
      (let
        ((opcode-value (assq opcode opcodes)))
        (if opcode-value
          (if (eq? opcode 'brtable)
            (let
              ((label-list (get-label-list operands)))
              (set! source-assembly-code
                (cons (cadr opcode-value) source-assembly-code))
              (set! source-assembly-code
                (append (reverse label-list) source-assembly-code))
              (set! pc (+ pc 1 (length label-list))))
            (begin
              (set! source-assembly-code 
                (cons (cadr opcode-value) source-assembly-code))
              (let
                ((instruction-length (length instruction)))
                (if (> instruction-length 1)
                  (if (= instruction-length 2)
                    (set! source-assembly-code
                      (cons (car operands) source-assembly-code))
                    (if (= instruction-length 3)
                      (set! source-assembly-code
                        (cons (cadr operands)
                              (cons (car operands) source-assembly-code)))
                      (set! source-assembly-code
                        (append (reverse operands) source-assembly-code)))))
                (set! pc (+ pc instruction-length)))))
          (begin
            (display "invalid opcode ")
            (display opcode)
            (newline)))))))

(define assembled-code '())

(define (create-assembled-code code)
  (if (null? code)
    '()
    (let
      ((word (car code)))
      (if (char? word)
        (set! assembled-code (cons (char->integer word) assembled-code))
        (if (symbol? word) ; resolve label reference
          (let
            ((reference (hash-ref labels word)))
            (if (null? reference)
              #f ; should be an error label not found
              (set! assembled-code
                (cons reference assembled-code))))
          (set! assembled-code
            (cons word assembled-code)))) ; integer already
      (create-assembled-code (cdr code)))))

(define (display-code code)
  (if (not (null? code))
    (let
      ((word (car code)))
      (display word)
      (newline)
      (display-code (cdr code)))))

(define (loop)
  (let
    ((instruction (read)))
    (if (not (eof-object? instruction))
      (begin
        (process-instruction instruction)
        (loop)))))

(loop)

(create-assembled-code (reverse source-assembly-code))
(set! assembled-code (reverse assembled-code))
(display (length assembled-code))
(newline)
(display-code assembled-code)

;(newline)
;(newline)
;(do ((i 0 (+ i 1))) ((= i (vector-length labels2)))
;  (display i) 
;  (display " ")
;  (display (vector-ref labels2 i))
;  (newline))
