#lang mzscheme

(require (lib "foreign.ss"))
(unsafe!)

(define ptr (make-thread-cell #f))
(define (get-ptr)
  (or (thread-cell-ref ptr)
      (let ([p (malloc _scheme 1)]) (thread-cell-set! ptr p) p)))

; set a pointer to the cons cell, then dereference it as a pointer,
; and bang the new value in the given offset
(define (set-ca/dr! offset who p x)
  (if (pair? p)
    (let ([p* (get-ptr)])
      (ptr-set! p* _scheme p)
      (ptr-set! (ptr-ref p* _pointer 0) _scheme offset x))
    (raise-type-error who "pair" p)))

(define (n-set-car! p x) (set-ca/dr! 1 'set-car! p x))
(define (n-set-cdr! p x) (set-ca/dr! 2 'set-cdr! p x))

; decide at run-time whether the underlying mzscheme supports
; set-car! and set-cdr!, since I can't figure out how to do it
; at compile time.
  ;NOOB

(define x-set-car!
  (let ((fn (namespace-variable-value 'set-car! #t (lambda () #f))))
    (if (procedure? fn)
        fn
        n-set-car!)))

(define x-set-cdr!
  (let ((fn (namespace-variable-value 'set-cdr! #t (lambda () #f))))
    (if (procedure? fn)
        fn
        n-set-cdr!)))


(define _q (list 'nil 'nil 0))
(define (_prn ach)
  (display ach)
  (newline))


(define (_verify q)
  (_prn q)
  (if (eq? (car q) 'nil)
      #f
      ; The contract for queues: q.1 is reachable from q.0
      (unless (let loop ((q0 (car q)))
                (cond ((eq? q0 'nil) #f)
                      ((eq? q0 (cadr q)) #t)
                      (#t (loop (cdr q0)))))
        (_prn "error^^^"))))

(define (rept n thunk)
  (if (= n 0)
      #f
      (begin (thunk)
             (rept (- n 1) thunk))))
(define (until test-thunk thunk)
  (if (test-thunk)
      #f
      (begin (thunk)
             (until test-thunk thunk))))

(define (_enq obj q)
  (let ((u (current-gc-milliseconds)))
    (x-set-car! (cddr q) (+ 1 (caddr q)))
    (if (eq? 'nil (car q))
        (x-set-car! (cdr q) (let ((u (cons obj 'nil)))
                              (x-set-car! q u)
                              u))
        (begin (x-set-cdr! (cadr q) (cons obj 'nil))
               (x-set-car! (cdr q) (cdr (cadr q)))))
    (unless (= u (current-gc-milliseconds))
      (_prn "GC around enq"))))

(define (_deq q)
  (let ((u (current-gc-milliseconds)))
    (unless (= (caddr q) 0)
      (x-set-car! (cddr q) (- (caddr q) 1)))
    (x-set-car! q (cdr (car q)))
    (unless (= u (current-gc-milliseconds))
      (_prn "GC around deq"))))

(define (_qlen q)
  (caddr q))

(define (run)
  (set! _q (list 'nil 'nil 0))
  (rept 1000000
        (lambda ()
          (_prn "iter")
          (rept (random 10)
                (lambda ()
                  (_verify _q)
                  (_enq 0 _q)))
          (_prn "deq")
          (until (lambda () (= 0 (_qlen _q)))
            (lambda ()
              (_verify _q)
              (_deq _q))))))

;(run)