#lang scheme/base



(provide locals-tx)


;; Syntax for local variables in macros.


;; 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))
            (((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.
               (((state+ var ...)
                  #,(length locals-list)
             ;; Create bindings for wrapper macros.
                 (lambda (v) #`(#,v #,(local-rep v)))
              ;; Apply the inner expression (expressed in terms of
              ;; (rpn-state)) to the state left over after popping the
              ;; variables.
              (let ((#,(rpn-state) state+))

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

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