(import chicken scheme ports data-structures)
(use srfi-1 extras posix)

(include "ev.scm")


(define (symbol->num-list sym)
  (map char->integer (string->list (symbol->string sym))))

(define (write-val v)
    (let loop ((v v) (acc '()))
      (if (= v 0)
          (for-each write-byte
                    (reverse
                     ;; NOTE assumes little endian
                     (append (make-list (- *word-size* (length acc)) 0) acc)))
          (loop (quotient v 256) (cons (remainder v 256) acc)))))


(define a (if (feature? 'debug)
              0
              #x220000))
(if (= a 0)
    (begin (newline) (print "!!!!!! heap-writer DEBUG MODE !!!!!") (newline)))

(define (write-cons obj1 obj2)
  (let ((start a))
    (write-val obj1)
    (write-val obj2)
    (set! a (+ a 16))
    start))

(define *oblist* '())
(define (make-heap obj)
  (define (tag-record obj) (bitwise-xor (arithmetic-shift obj 2) record-spec))
  (define symbol-tag (tag-record (untag-record (record-obj-type (make-symbol '())))))
  (define (tag-nil) (tag-record (tag-number 0)))
  (define (has-symbol? sym)
    (alist-ref sym *oblist*))
  (define (push-oblist-symbol sym loc)
    (set! *oblist* (cons (cons sym loc) *oblist*)))
  (define (oblist-symbol-record sym)
    (alist-ref sym *oblist*))
  ;; (define (tag-number n) n)
  (define (loop obj)
    (cond ((number? obj)
           (tag-number obj))
          ((nil? obj)
           (tag-nil))
          ((record? obj)
           (tag-record (untag-record obj)))
          ((record-obj? obj)
           (write-cons (tag-record (untag-record (record-obj-type obj)))
                       (loop (record-obj-value obj))))
          ((symbol? obj)
           (if (has-symbol? obj)
               (oblist-symbol-record obj)
               (let ((rec (write-cons symbol-tag
                                      (write-cons (loop (symbol->num-list obj))
                                                  (tag-nil)))))
                 (push-oblist-symbol obj rec)
                 rec)))
          ((pair? obj)
           (write-cons (loop (car obj)) (loop (cdr obj))))
          (else (error "unknown"))))
  (loop obj))

(with-output-to-file (if (feature? 'debug) "heap-debug.bin" "heap.bin")
  (lambda ()
    ;; (set! a 0)
    ;; (set! *oblist* '())
    ;; lets call the stuff at the beginning "the header"
    ;; could also include the tip of the oblist (and make the oblist
    ;; an actual list of its own) Also, make the header real big for
    ;; future binary compatibility so more things can be added to it
    ;; without causing old images to become invalid
    ;; also make the values in the headers offsets and have ev.scm
    ;; calculate the actual location that way the heap can be moved to
    ;; places in memory without having to recompile
    ;; ALSO add to header the end of the heap so that *alloc-address*
    ;; can be set to it when run-ev starts
    (write-val 0) ; written over for env start address
    (write-val 0) ; written over for exps start address
    (set! a (+ a 16))
    (make-heap (eval (car (read-file "ev-environment.scm"))))
    (let ((fp (file-position (current-output-port))))
      (set-file-position! (current-output-port) 0)
      (write-val (- a 16))
      (set-file-position! (current-output-port) fp))
    (make-heap (read-file "ev-runtime.scm"))
    (set-file-position! (current-output-port) 8)
    (write-val (- a 16))
    ))