#lang scheme/base
;; Syntax transformer utilities for pattern.ss


(require
 "../tools.ss"
 "../tools-tx.ss"
 "../scat-tx.ss"
 scheme/pretty
 (for-template
  scheme/base
  "../tools.ss"
  "../scat.ss"
  "pattern-runtime.ss"
  scheme/match
  ;; (lib "match.ss")
  ))


;; 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:

(provide
 asm-pattern-tx
 asm-template-tx
 asm-lambda-tx
 asm-transforms-tx
 with-asm-transforms-tx
 check-opcodes-tx
 )


;; 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)
  (map
   (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 ...) ...)
     (begin
       (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)
     (values 
      (name->identifier #'name)         ;; Convert strings to identifiers.
      (let ((pattern-lst
             (reverse                   ;; Reverse pattern at compile time.
              (asm-pattern-tx
               #'(asm-pattern ...))))
            (template
             #`(macro/append-reverse    ;; Reverse asm code result at runtime.
                #,(asm-template-tx #'expr)
                rest)))
        (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)
  (map*
   ;; Transpose output of collect.
   (lambda (name . orig/clause)
     (list name
           (map first orig/clause)
           (map second orig/clause)))
   ;; Collect clauses per macro.
   (collect
    free-identifier=?
    (map
     (lambda (orig)
       (let-values
           (((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)))
  #`(pattern-tx->macro
     '#,name
     #,(quasisyntax/loc
        name
        (match-lambda #,@clauses))))




(define (transform-bindings specs)
  (map*
   (lambda (name origs clauses)
     #`(#,name
        (make-word
         #,(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)
  (with-opcode-checks
   (lambda ()
     #`(redefinitions!-ns
        #,namespace
        #,@(transform-bindings specs)))))

;; Define multiple parameter words.

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


;; 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)))
    (apply
     (lambda (origs clauses)
       #`(make-word
          #,(clauses->word #'<anonymous> clauses)
          '((pattern . #,origs))))
     (list
      (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 target-compile.ss

(define *opcodes* '())

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


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

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

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