#lang racket
(require (only-in plai error test test/exn print-only-errors))

;; define .... placeholder syntax like plait
(define-syntax ....
  (lambda (stx)
    (syntax-case stx ()
      [_ (syntax/loc stx
           (error "reached a `....` placeholder"))])))

;; Emulate a small part of the plai/gc2/collector language
(define current-heap (make-parameter (make-vector 0 #f)))
(define (heap-set! index val) (vector-set!  (current-heap) index val))
(define (heap-ref index) (vector-ref (current-heap) index))
(define (heap-size) (vector-length (current-heap)))
(define (simple-root loc) (box loc))
(define (read-root root) (unbox root))
;; allocation pointer in word 0
(define (set-ptr! v) (heap-set! 0 v))

(define (malloc n)
  (define addr (heap-ref 0))
  (unless (<= (+ addr n) (heap-size))
    (error 'allocator "out of memory"))
  (heap-set! 0 (+ addr n))
  addr)

(define-syntax-rule (with-heap vec expr ...)
  (parameterize  ([current-heap vec]) (begin expr ...)))

;; Convenience functions for tagged heap access
(define (expect addr tag)
  (unless (equal? (heap-ref addr) tag)
    (error 'expect "expecting ~a at ~a" tag addr)))
(define (heap-put! tag addr offset val)
  (expect addr tag) (heap-set! (+ addr offset) val))

;; Partial implementation of a collector API
(define (gc:alloc-flat x)
  (define loc (malloc 2))
  (heap-set! loc 'flat)
  (heap-put! 'flat loc 1 x)
  loc)

(define (gc:cons f r)
  (define loc (malloc 3))
  (heap-set! loc 'cons)
  (heap-put! 'cons loc 1 (read-root f))
  (heap-put! 'cons loc 2 (read-root r))
  loc)

(define (init-allocator) (set-ptr! 1))

;; coverage tests
(module+ test
  (with-heap (make-vector 4 'free)
    (init-allocator)
    (test/exn (malloc 10) "out of memory")
    (test/exn (expect 1 'flat) "expecting")))

(define (flat-2 a b)
  (with-heap (make-vector 5 'free)
    (init-allocator)
    (gc:alloc-flat a)
    (gc:alloc-flat b)
    (current-heap)))
(define (cons-2 a b)
  (with-heap (make-vector 8 'free)
    (init-allocator)
    (gc:cons (simple-root (gc:alloc-flat a)) (simple-root (gc:alloc-flat b)))
    (current-heap)))
(define (self-cons)
   (with-heap (make-vector 4 'free)
    (init-allocator)
    (define loc (malloc 0)) ; Hack to get current heap pointer
    (gc:cons (simple-root loc) (simple-root loc))
    (current-heap)))
(define (list-3 a b c)
  (with-heap (make-vector 20 'free)
    (init-allocator)
    (define one (gc:cons
               (simple-root (gc:alloc-flat c))
               (simple-root (gc:alloc-flat (list)))))
    (define two (gc:cons
               (simple-root (gc:alloc-flat b))
               (simple-root one)))
    (gc:cons
     (simple-root (gc:alloc-flat a))
     (simple-root two))
    (current-heap)))
; Why is this, which is the exact same as this, except the defines inlined producing a different structure?
#;(define (list-3 a b c)
  (with-heap (make-vector 20 'free)
    (init-allocator)
    (gc:cons
     (simple-root (gc:alloc-flat a))
     (simple-root (gc:cons
                   (simple-root (gc:alloc-flat b))
                   (simple-root (gc:cons
                                 (simple-root (gc:alloc-flat c))
                                 (simple-root (gc:alloc-flat (list))))))))
    (current-heap)))

(module+ test
  (test (flat-2 1 2) #(5 flat 1 flat 2))
  (test (flat-2 'flat 'cons) #(5 flat flat flat cons))
  (test (flat-2 'cons 'flat) #(5 flat cons flat flat))

  (test (cons-2 'first 'rest) #(8 flat first flat rest cons 1 3))
  (test (cons-2 1 2) #(8 flat 1 flat 2 cons 1 3))
  (test (cons-2 'cons 'cons) #(8 flat cons flat cons cons 1 3))

  (test (self-cons) #(4 cons 1 1))

  (test (list-3 'cons 'cons 'cons) '#(18 flat cons flat () cons 1 3 flat cons cons 8 5 flat cons cons 13 10 free free))
  (test (list-3 'flat 'flat 'flat) '#(18 flat flat flat () cons 1 3 flat flat cons 8 5 flat flat cons 13 10 free free))
  (test (list-3 1 2 3)             '#(18 flat 3 flat () cons 1 3 flat 2 cons 8 5 flat 1 cons 13 10 free free)))