#lang scheme/base
;; Syntax transformer utilities for

  ;; (lib "")

;; Output assembly is accumulated in reverse on the stack for
;; efficiency (cons). The pattern matcher macros will present a
;; normal ordering, so they require to reverse both the pattern at
;; compile time and the eventual expression at run time. This module
;; exports a single function that performs the pattern compilation:


;; The core pattern transformer produces a 'match' clause by reversing
;; the pattern, at compile time for the matcher macro to use, and the
;; result of the expression, postponed to runtime.  Pack the result as
;; (name-symbol match-clause-tx)

;; Pattern/Template syntax.

;; This is a layer on top of the 'raw' pattern syntax that assumes all
;; list elements referred in pattern and template have a tag symbol
;; and removes the burden of quoting/unquoting, simulating
;; struct-style matching.

;; These will register all references to assembler opcodes for error
;; checking.

;; The transformer adds the appropriate quoting to the pattern and
;; unquoting to the template.

(define (asm-pattern-tx stx)
   (lambda (ins)
     (syntax-case ins (unquote)
       (,instruction           #'instruction)
       ((,tag arg ...)         #`(list tag arg ...)) 
       ((,tag arg ... . args)  #`(list-rest tag arg ... args)) 
       ((tag arg ...)          (begin
                                 (register-opcode ins)
                                 #`(list 'tag arg ...)))))
   (syntax->list stx)))

;; Parse the template as either the specific assembler syntax, or an
;; arbitrary scheme expression.
(define (asm-template-tx stx)
  (syntax-case stx (macro:)
    (((op arg ...) ...)
       (for-each register-opcode (syntax->list stx))
       #`(quasiquote ((op (unquote arg) ...) ...))))
    (_  stx)))

(define (spec->name/match-clause stx)
  (syntax-case stx () 
    (((asm-pattern ... name) expr)
      (name->identifier #'name)         ;; Convert strings to identifiers.
      (let ((pattern-lst
             (reverse                   ;; Reverse pattern at compile time.
               #'(asm-pattern ...))))
             #`(macro/append-reverse    ;; Reverse asm code result at runtime.
                #,(asm-template-tx #'expr)
        (if (null? pattern-lst)
            #`(rest #,template)
            #`((list-rest #,@pattern-lst rest) #,template)

;; Apply the above transformation for all patterns, and collect all
;; clauses for a single macro.

;; (<macro-name> <orig-patterns> <clauses>)

(define (specs->clause-dict specs)
   ;; Transpose output of collect.
   (lambda (name . orig/clause)
     (list name
           (map first orig/clause)
           (map second orig/clause)))
   ;; Collect clauses per macro.
     (lambda (orig)
           (((name clause)
             (spec->name/match-clause orig)))
         (cons name                  ;; collect name
               (list orig clause)))) ;; payload
     ;; Straight from syntax object.
     (syntax->list specs)))))

;; Represent a list of match clauses.
(define (clauses->word name clauses)
  ;; (pretty-print (syntax->datum #`(#,name #,clauses)))
        (match-lambda #,@clauses))))

(define (transform-bindings specs)
   (lambda (name origs clauses)
         #,(clauses->word name clauses)
         '((pattern: . #,origs)))))
   (specs->clause-dict specs)))

;; Main transformer. This uses 'specs->clause-dict' and
;; 'clauses->word' to construct the outer scheme
;; expression. Redefinitions are allowed, and have the 'super' word
;; bound in the namespace.

(define (asm-transforms-tx namespace specs)
   (lambda ()
        #,@(transform-bindings specs)))))

;; Define multiple parameter words.

(define (with-asm-transforms-tx namespace specs)
  #`(lambda (thunk)
      (parameterize-words-ns! #,namespace
       #,(transform-bindings specs)

;; Anonymous transformer. The name in the pattern is ignored. By
;; convention _ is used.
(define (asm-lambda-tx specs)
  (let* ((clause-dict
          (specs->clause-dict specs)))
     (lambda (origs clauses)
          #,(clauses->word #'<anonymous> clauses)
          '((pattern . #,origs))))
      (apply append (map second clause-dict))
      (apply append (map third clause-dict))))))

;; Assembler opcode symbol checking. Since assembler opcodes are
;; late-bound, we keep track of where they were used, so these checks
;; can be postponed until runtime.

;; FIXME: unify error reporting with the one in

(define *opcodes* '())

(define (with-opcode-checks thunk)
  (let ((out (thunk)))
    ;; (report-opcodes)
(define (register-opcode stx)
  (syntax-case stx ()
    ((op . args)
     (identifier? #'op)
     (push! *opcodes*
            (list #'op
                  (length (syntax->datum #'args)))))
    (_ (void))))

(define (collect-opcodes)
    (lambda (stx arity)
      (list (syntax->datum stx)
            (syntax-source stx)
            (syntax-line stx)
            (syntax-column stx)
            (syntax-position stx)
            (syntax-span stx)))

(define (report-opcodes)
   (lambda (name . locs)
     (printf "~a ~a\n" name (length locs)))

(define (check-opcodes-tx stx)
  (syntax-case stx ()
    ((_ asm-find)
        (quote #,(collect-opcodes))))))