#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) ....)
(define (cons-2 a b) ....)
(define (self-cons) ....)
(define (list-3 a b c) ....)

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