#lang scheme/base

;; Tools for accessing the code stack useful for macro evaluation.

(require
 "../op.ss"
 "../ns.ss"
 "../scat.ss"
 "../target/rep.ss"
 "op.ss"
 scheme/match)

(provide

 state->value
 state->code
 
 asm-pop
 state-pop

 insert
 
 state-print-code

 tag-stack

 macro-list->state
 state->macro-list


 macro->target-word
 macro-target-word?
 )

;; Evaluate macro to expose the target word call it wraps.  Will raise
;; 'invalid-argument when it's not a wrapping macro.
(define (macro->target-word x)
  (unless (word? x)
    (error 'macro->target-word "~s" x))
  (let ((v
         (state->value
          (x (state:stack))
          (ns (op ? cw)))))
    v))
(define (macro-target-word? m)
  (with-handlers ((void (lambda _ #f)))
    (macro->target-word m)
    #t))
    


(define (state-print-code state)
  (for ((ins (map instruction->string
                  (reverse (stack-list state)))))
    (display ins)
    (newline)))


;; *** COMPILATION TOOLS ****

(define (tag-stack s tag)
  (map (lambda (v) (list tag v)) s))

(define state->code stack-list)

;; Obtain single tagged value from state.  Used in macro evaluation.
(define (state->value state tag?)
  (let-values
      (((asm vals)
        (asm-pop (stack-list state) 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 ([s '()]) (make-state:stack s))))


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

;; nvals = negative -> pop all

(define (asm-pop in-instructions nvals tag?
                 [trouble #f])
  (let loop ((ins  in-instructions)
             (n    nvals)
             (vals '()))
    (if (or
         (zero? n)
         (and (< n 0) (null? ins)))
        (values ins vals)
        (begin
          (when (null? ins)
            (if trouble (trouble)
                (error 'asm-pop-stack-underflow
                       "~s: ~s" nvals in-instructions)))
          (let ((op (car ins)))
            (unless
                (and
                 (pair? op)
                 (tag? (car op))
                 (pair? (cdr op)))
              (if trouble (trouble)
                  (error 'invalid-argument
                         "~a" (cons (asm-name (car op)) (cdr op)))))
            (loop (cdr ins)
                  (- n 1)
                  (cons (cadr op) vals)))))))

(define (state-pop 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 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)))))


;; Convert a list of macros to a state by running them one by one.
(define (macro-list->state macro-list make-state)
  (foldl (lambda (macro state) (macro state))
         (make-state)
         macro-list))

;; Convert a state (a list of instructions) to a list of macros that
;; produce the instructions one by one).
(define (state->macro-list state)
  (map (lambda (x) (scat: ',x)) ;; quote the whole instruction
       (reverse (state->code state))))