#lang scheme/base
(require
 "../scat.ss"
 "../target/rep.ss"
 scheme/match)

(provide
  ;; tools
 ;; empty-ctrl->asm
 ;; assert-empty-ctrl
 macro->data  
 macro->code
 macro-eval-init-state
 macro-state-check
 
 asm-pop-unquote
 state-pop-unquote

 insert
 
 print-macro-code
 
 )

(define (print-macro-code m)
  (for ((ins (map instruction->string
                  (reverse (macro->code m)))))
       (display ins)
       (newline)))




;; *** COMPILATION TOOLS ****


;; Compile code by executing a macro on empty state, but with limited
;; compiler state: no splits allowed.

(define (macro->code macro (name '<anonymous>))
  (let ((end-state (macro ((macro-eval-init-state)))))
    ((macro-state-check) end-state name)
    (stack-list end-state)))
;; (empty-ctrl->asm end-state name)))

;; This needs to be overridden with empty control stack checks.
(define macro-state-check
  (make-parameter void))



;; Execute macro and interpret result as literal. Does not perform
;; meta-evaluation.
(define (macro->data macro [tag 'qw])
  (let-values
      (((asm vals)
        (asm-pop-unquote (macro->code macro) 1 tag)))
    (unless (null? asm)
      (error 'multiple-asm-values "~s" asm))
    (car vals)))


;; State construction is abstracted, in case there are macros operate
;; on extended state.

(define macro-eval-init-state
  (make-parameter
   (lambda () (make-state:stack '()))))


;; POP & UNQUOTE
;; access tagged values on the stack

(define (asm-pop-unquote in-asm nvals tag)  
  (let loop ((asm  in-asm)
             (n    nvals)
             (vals '()))
    (if (zero? n)
        (values asm vals)
        (begin
          (when (null? asm)
            (error 'asm-pop-stack-underflow
                   "~s,~s: ~s" tag nvals in-asm))
          (let ((op (car asm)))
            (unless
                (and
                 (pair? op)
                 (eq? tag (car op))
                 (pair? (cdr op)))
              (error 'invalid-argument
                     "~a, expected [~a <val>]\n"
                     op tag))
            (loop (cdr asm)
                  (- n 1)
                  (cons (cadr op) vals)))))))

(define (state-pop-unquote state nvals tag)
  ;; The abstract state update machanism has no way to split data off
  ;; state, so use local (single) assignment.
  (define popped-values #f)
  (define state+
    ((state-lambda stack
                   (asm)
                   (update
                    (let-values
                        (((asm+ vals)
                          (asm-pop-unquote asm nvals tag)))
                      (set! popped-values vals)
                      asm+)))
     state))
  (values state+ popped-values))


(define (insert instructions)
  (make-word
   (state-lambda stack
                 (asm)
                 (update (append (reverse instructions) asm)))))