#lang scheme/base

(require
 "../scat-tx.ss"
 "../tools-tx.ss"

 (for-template
  "../scat.ss"
  "locals-runtime.ss"
  scheme/base))


(provide locals-tx)

         

;; Syntax for local variables in macros.

;; LOCAL BINDINGS

;; Local variables in macro definitions have the semantics of
;; constants. Variants are possible where the local names represent
;; RAM variables or words.




;; Delimited parsing (unflattening): collect a list of syntax objects
;; upto and excluding a marker symbol.
(define (stx-split stx sym)
  (let next ((s stx) (l '()))
    (if (stx-null? s)
        (error 'stx-split-eof "looking for `~s' in: ~s"
               sym (syntax->datum stx))
        (let-values
            (((head tail) (stx-uncons s)))
          (if (eq? sym (syntax->datum head))
              (values (reverse l) tail)
              (next tail (cons head l)))))))
            
(define (rep-constant stx)
  (rpn-compile #`(',#,stx)))

(define (locals-tx code exp)
  (locals-generic rep-constant #'qw code exp))


;; Read parameters and create a wrapper procedure.


(define (locals->wrapper local-rep tag locals-list before-expr)
  (define closed-before
    (rpn-close-expression before-expr))
  (lambda (expr)
    (syntax-case locals-list ()
      ((var ...)
       ;; Close accumulated expression and apply it to input
       ;; state. This allows locals to be introduced anywhere in
       ;; the function body.
       #`(let ((state (#,closed-before #,(rpn-state))))
           ;; Create bindings for literal values.
           (let-values
               (((state+ var ...)
                 (state-pop-unquote/locals
                  state
                  #,(length locals-list)
                  '#,tag)))
             ;; Create bindings for wrapper macros.
             (let-ns
              (macro)
              #,(map
                 (lambda (v) #`(#,v #,(local-rep v)))
                 locals-list)
              ;; Apply the inner expression (expressed in terms of
              ;; (rpn-state)) to the state left over after popping the
              ;; variables.
              (let ((#,(rpn-state) state+))
                #,expr))))))))

(define (locals-generic local-rep tag code expr)
  (syntax-case code ()
    ((_ . locals/code+)
     (let-values
         (((locals code+)
           (stx-split #'locals/code+ '\|)))

       ;; Modify expression wrapping Note that this is a permanent
       ;; modification untile 'rpn-close-expression' gets called.
       (rpn-current-close
        (compose (rpn-current-close)
                 (locals->wrapper local-rep tag locals expr)))
       ((rpn-next) code+ (rpn-state))))))