#lang scheme/base

;; Code representation is independent of the compiler.
(require
 scheme/control
 scheme/serialize
 scheme/match
 "../tools.ss")


(provide
 print-target-word
 new-target-word
 word?->name
 instruction->string
 (struct-out target-word)
 target-word->error-string

 ;; expression evaluation
 target-value-delay   ;; create generic delayed meta expressions
 target-value->number ;; evaluate delayed meta expressions
 target-value-eval
 target-value-partial-eval
 
 target-value-abort   ;; used in constants.ss to indicate undefined values
 
 (struct-out target-value)

 target-value-catch-undefined   ;; used by the assembler to catch assembly
                        ;; aborts due to unresolved addresses.

 target-chain->list    ;; unpack multiple entry points into a list
 ;;target-chain->binary  ;; get all binary code in a list

 target-chains->bin    ;; convert all code in a code chain to 'bin' datastructure

 target-code-unit      ;; word->byte translation
 target-code-bits      ;; word size for disassembler
 target-address-size   ;; address width for printing
 )

;; A forth word is an instantiated macro. It is represented by 2 parts:
;;  * a code word structure.
;;  * a macro which compiles a reference to the code word
 
;; If code is a list, it represents assembly code. If it is a
;; procedure, it represents code in postponed form (macro to by
;; applied to empty state).

(define-serializable-struct target-word
  (name realm code srcloc address bin next postponed)
  #:mutable)


(define target-code-unit (make-parameter #f))
(define target-code-bits (make-parameter #f))


(define (new-target-word #:name      [name '<anonymous>]
                         #:realm     [realm 'code]
                         #:code      [code #f]
                         #:srcloc    [srcloc #f]
                         #:address   [address #f]
                         #:bin       [bin #f]
                         #:next      [next #f]
                         #:postponed [postponed #f]
                         )
  (make-target-word name
                    realm code
                    srcloc address
                    bin next postponed))

;; Target words have internal link structure: if they do not end in a
;; jump instruction, they fall through to the next one. This function
;; unlinks a word into a list of words in compilation order (reversed,
;; so it can act as an 'append' list).

(define (target-chain->list word [l '()])
  (let ((next (target-word-next word))
        (l+ (cons word l)))
    (if next
        (target-chain->list next l+)
        l+)))

;; Convert a word chain to an ordered list of machine words.

(define (target-chains->bin chain-list [realm 'code])
  (prompt
   (bin-flatten
    (map
     (lambda (c)
       (list
        (target-word-address c) 
        (reverse
         (flatten
          (map (lambda (word)
                 (let ((bin (target-word-bin word)))
                   (or bin (abort #f))))
               (target-chain->list c))))))
     (reverse
      (filter
       (lambda (w)
         (eq? (target-word-realm w) realm))
       chain-list))))))



;; TARGET WORD (PARTIAL) EXPRESSION EVALUATION

;; Abstraction to create and evaluate reflective computations
;; depending on (numerical) target word addresses.

;; Evaluation of these computations is directed by the assembler,
;; which will catch aborts due to unavailability of addresses during a
;; certain phase and will restart computations until all words are
;; defined and the machine code is relaxed.



(define-struct target-value (thunk pe-thunk))

(define target-value-tag
  (make-continuation-prompt-tag 'meta))
(define (target-value-abort)
  (abort-current-continuation
   target-value-tag (lambda () #f)))
(define (target-value-catch-undefined thunk)
  (prompt-at target-value-tag (thunk)))

  

;; Undefined words will abort. This is internal: used only to
;; recursively evaluate target-value references.
(define (target-value-eval expr)
  (cond
   ((target-value? expr) ((target-value-thunk expr)))
   ((target-word? expr)  (or (target-word-address expr)
                             (target-value-abort)))
   (else expr)))

;; Partial evaluation: similar, but pick the other thunk.
(define (target-value-partial-eval expr)
  (cond
   ((target-value? expr) ((target-value-pe-thunk expr)))
   ((target-word? expr)  (target-word-name expr))
   (else expr)))

  
;; Evaluate the thunks
(define (target-value->number
         expr
         [e (lambda (n)
              (error 'target-value-type-error
                     "not a number: ~a" n))])
  (let ((n (target-value-eval expr)))
    (unless (number? n) (e n))
    n))

;; Partual evaluation: evaluate fully of possible, otherwise return
;; source expression.
(define (target-value->expr expr)
  (target-value-partial-eval expr))


(define-syntax target-value-delay
  (syntax-rules ()
    ((_ e1 e2)   
     (make-target-value
      (lambda () e1)    ;; evaluate
      (lambda () e2)))  ;; partially evaluate
    ((_ expr)
     (target-value-delay
      expr
      (raise 'no-partial-evaluation)))
    ))


;; FORMATTING

(define (target-word->error-string w)
  (let ((s (target-word-srcloc w)))
    (and s
         (apply
          (lambda (file line column position span)
            (format "~a:~a:~a: ~a"
                    file line column
                    (target-word-name w)))
          s))))

(define (word?->name r)
  (if (not (target-word? r)) r
      (target-word-name r)))

(define target-address-size (make-parameter #f))

(define (instruction->string ins [term ""])
  (if (not (list? ins))
      (format "~a~a" ins term)
      (let ((name (car ins))
            (args (map
                   target-value->expr
                   (cdr ins))))
        (format "[~a~a]~a"
                name
                (if (null? args)
                    ""
                    (apply string-append
                           (map (lambda (x)
                                  (format " ~s" x))
                                args)))
                term))))

(define (print-target-word word (port (current-output-port)))
  (for-each (lambda (w)
              (print-target-word-head w port))
            (reverse
             (target-chain->list word))))

;; There are 2 modes: with binary and without. If a word has an
;; address, it is assumed that it also has binary code.
(define (print-target-word-head word port
                                [addr-conv
                                 (lambda (x) (* x (target-code-unit)))])
  (define w->s word->string)
  (define (a->s x) (hex->string (/ (target-address-size) 4) x))
  
  (define (hex x)
    (cond
     ((list? x)   (apply string-append
                         (map (lambda (y)
                                (format "~a " (w->s y)))
                              x)))
     ((number? x) (w->s x))
     (else "")))
  (parameterize ((current-output-port port))
    (let* ((addr (target-word-address word))
           (bin  (and addr (reverse (target-word-bin word))))
           (code (map instruction->string
                      (reverse (target-word-code word)))))
      (printf "~a:\n"
              (match
               (target-word-name word)
               ((list _ v) (a->s (addr-conv (target-value->number v))))
               (sym sym)))
      (let next ((a addr)
                 (b bin)
                 (c code))
        (unless (null? c)
          (display "\t")
          (when a (printf "~a ~a"
                          (hex (addr-conv a))
                          (hex (car b))))
          (printf "~a\n" (car c))
          (next (and a (+ (length (car b)) a))
                (and a (cdr b))
                (cdr c)))))))


;; (printf "instantiating target/rep\n")