#lang scheme/base

;; Current assembly pointers
(require
 "../tools.ss")
(provide
 pointer-get
 pointer-set!
 pointer-allot!
 pointer-push!
 pointer-pop!
 current-pointers
 with-pointer

 asm-current-word
 asm-current-chain
 asm-current-instruction

 )

(define asm-current-word (make-parameter #f))
(define asm-current-chain (make-parameter #f))
(define asm-current-instruction (make-parameter #f))

(define (with-pointer ptr value thunk)
  (dynamic-wind
      (lambda () (pointer-push! ptr value)) thunk
      (lambda () (pointer-pop! ptr))))
  



;; For the imperative algos, use a hash table data structure.
(define get  hash-ref)
(define put! hash-set!)
(define table alist->hash)
(define table->alist hash->alist)

;; Assembly address environment. The pointers use shallow binding:
;; each is a stack of values. These values are incremented during
;; assemble, and are allowed to be changed at the start of each word.
(define current-pointers
  (make-parameter
   (table '((code 0)
            (data 0)))))

(define (pointer-stack name)
  (get (current-pointers) name))
(define (pointer-stack! name stack)
  (put! (current-pointers) name stack))

(define (pointer-pop! name)
  (let ((s (pointer-stack name)))
    (pointer-stack! name (cdr s))
    (car s)))
(define (pointer-push! name val)
  (let ((s (pointer-stack name)))
    (pointer-stack! name (cons val s))))

(define (pointer-set! name val)
  (let ((s (pointer-stack name)))
    (pointer-stack! name (cons val (cdr s)))))
(define (pointer-get name)
  (car (pointer-stack name)))

(define (pointer-allot! name increment)
  ;; (printf "alloting ~a ~a\n" name increment)
  (pointer-set! name
                (+ increment
                   (pointer-get name))))