#lang scheme/base

(require
 "../tools.ss"
 "../target.ss"
 "../scat.ss"
 "../asm/dictionary.ss"
 ;; scheme/pretty
 scheme/match)

(provide
 (all-defined-out))


(define (macro/append-reverse code rest)
  (if (procedure? code)  ;; doesn't need list wrapper
      (cons code rest)
      (append (reverse code) rest)))

(define (at-most lst n [trunc-tail '()])
  (cond
   ((null? lst) '())
   ((zero? n)   trunc-tail)
   (else
    (cons (car lst)
          (at-most
           (cdr lst)
           (- n 1)
           trunc-tail)))))

(define (pattern-failed name asm)
  (error 'asm-pattern
         "match failed for: ~a, asm:\n~a"
         name
         (apply string-append
                (map (lambda (ins) (instruction->string ins "\n"))
                     (reverse (at-most asm 4 '(...)))))))

(define (with-match-error-handler name asm thunk)
  (with-handlers
      ((exn:misc:match?
        (lambda (ex)
          (pattern-failed name asm))))
    (thunk)))

;; Lift transformation code (which operates on list structure) to
;; operate on Scat state + execute continuations.
(define (pattern-tx->macro name xform)

  ;; map asm-in -> continuation + asm-out
  (define (k/asm asm-in)
    (let ((asm
           (with-match-error-handler
            name asm-in
            (lambda () (xform asm-in)))))
      (cond
       ((null? asm)            (values id '()))
       ((procedure? (car asm)) (uncons asm))      ;; pass egg
       ((list? (car asm))      (values id asm))   ;; type check
       (else
        (error 'pattern-result-type-error
               "~a" asm)))))

  (state-lambda stack
                (asm)
                (let-values
                    (((k asm+) (k/asm asm)))
                  (k (update asm+)))))
  

;; Assembler opcode + arity checking.
(define (check-ops asm-find records)
  (for-each*
   (lambda (name . occurances)
     (let ((asm (asm-find name)))
       (map* (lambda (arity f l c p s)
               (define (err msg)
                 (error msg "~a:~a:~a: ~a" f l c name))
               (unless asm
                 (err 'undefined-opcode))
               (let ((n (procedure-arity asm)))
                 (unless
                     (if (number? n)
                         (= arity n)
                         (>= arity (arity-at-least-value n)))
                   (err 'asm-arity-error))))
             occurances)))
   records))