#lang scheme/base

;; RPN language syntax transformer functions.

(require
 "../tools.ss"
 "../tools-tx.ss"
 syntax/stx
 (for-template
  scheme/base))

(provide

 ;; source representation
 rpn-lambda           ;; convert program source -> lambda expression
 rpn-next             ;; perform next compilation action (recurses)

 ;; functions / data
 rpn-immediate        ;; push
 rpn-function         ;; apply

 ;; special forms
 rpn-program          ;; push delayed program
 rpn-quoted           ;; push quoted datum
 rpn-quasiquoted      ;; push quasiquoted datum

 ;; name space management
 rpn-map-identifier

 ;; outer wraps
 rpn-default-lambda    ;; representation as lambda + pass rest of input
 rpn-close-expression
 rpn-current-close
 rpn-init              ;; enter the parser, setting all necessary variables.

 ;; utils
 rpn-compile           ;; map code list -> scheme lambda expression
 rpn-state             ;; name of the state parameter in representation
 rpn-context           ;; run thunk in dynamic RPN environment
 rpn-tx->syntax        ;; create expander with current RPN environment
 rpn-lex-mapper        ;; special handling of lexical variables
 rpn-wrap              ;; simple expression wrapping FIXME: rename or get rid of

 transformer
 )

;; The RPN language distingishes between code (function) and data
;; (immediate) objects.

(define (immediate  object expr) #`(#,object #,expr))
(define (function   object expr) #`(apply #,object #,expr))

;; RPN functions are represented as a nested scheme expression wrapped
;; in a lambda to bind the input argument stack. This function
;; performs that wrapping.

(define (rpn-default-lambda body)
  #`(lambda (#,(rpn-state)) #,body))

;; Representation with garbage check (needs to consume the whole expression).
(define (rpn-init thunk)
  (parameterize
      ((rpn-current-close (rpn-lambda)))
    (thunk)))


(define (rpn-compile code)
  (rpn-init
   (lambda ()
     (let-values (((code+ body)
                   ((rpn-next) code (rpn-state))))
       (if (stx-null? code+)
           (rpn-close-expression body)
           (raise-syntax-error #f "garbage at end of code" code+))))))

(define rpn-current-close (make-parameter #f))
(define (rpn-close-expression expr)
  (let ((result ((rpn-current-close) expr)))
    (rpn-current-close (rpn-lambda))
    result))


;; Namespace resolution. If the function doesn't map to an identifier,
;; it must map to syntax, and will be expanded to obtain a true
;; identifier.
(define (map-identifier/expand id)
  (let ((stx ((rpn-map-identifier) id)))
    (if (identifier? stx)
        stx
        (let ((exp-stx (expand-syntax-once stx)))
          '(printf "EXPANDING: ~a ~a ~a\n"
                   (syntax->datum id)
                   (syntax->datum stx)
                   (syntax->datum exp-stx))
          exp-stx))))

        


;; Perform compilation recursively. The running state is the source
;; code list and the accumulated output expression. If the next
;; identifier is a transformer, pass on the source and the
;; expression. Otherwise call combine to compile the current datum
;; onto the accumulated expression.

(define (next source expr)
  (syntax-case source ()
    (() 
     (values source expr))
    ((id . source+)
     (let ((datum (syntax->datum #'id)))
       ;; (printf "T: ~a\n" datum)
       ((or
         (and
          ;; Continuation left by other macro. Same semantics as parser
          ;; macro.
          (procedure? datum)
          (lambda () (datum source expr)))
         
         (and
          (identifier? #'id)
          (let*
              ((mid (map-identifier/expand #'id))
               (tx  (transformer mid)))
            
            ;; The transformer needs to be called directly anyway to
            ;; preserve the dynamic environment (i.e. rpn-next), so such
            ;; transformers can conveniently be binary functions. Note
            ;; that calling direct means the transformer acts as part of
            ;; the 'represent' macro for identifier hygiene. This macro
            ;; typically produces a lambda expression.
            
            (and tx
                 (lambda ()
                   (tx source expr))))) ;; special kind
         
         (lambda ()
           ((rpn-next)
            #'source+
            (combine #'id expr)))))))))
        


;; Check if identifier has a transformer binding.
(define (transformer id-stx)
  (let ((binding
         (syntax-local-value
          id-stx (lambda () #f))))
    binding))
;;     (and binding
;;          (procedure? binding)
;;          (= 2 (procedure-arity binding)))))


;; Quote supports unquote as a way to introduce arbitrary scheme
;; values into s-expressions.

(define (quoted object expr)
  (define (lex/uq stx)
    (syntax-case stx (unquote)
      ((unquote atom)
       #'(unquote atom))
      ((car . cdr) 
       #`(#,(lex/uq #'car) . #,(lex/uq #'cdr)))
      (atom
       #'atom)))
  ((rpn-immediate)
   #`(quasiquote #,(lex/uq object))
   expr))

;; Quasiquotation is intended to build datastructures containing
;; function objects, not to substitute scheme values.

(define (quasiquoted object expr)
  (define (uq stx)
    (syntax-case stx (unquote)
      ((unquote expr)
       #`(unquote
          #,(rpn-compile #'expr)))  ;; program?
      ((car . cdr)
       #`(#,(uq #'car) . #,(uq #'cdr)))
      (atom
       #'atom)))
  ((rpn-immediate)
   #`(quasiquote #,(uq object))
   expr))

;; Quoted programs.

(define (program p expr)
  ((rpn-immediate)
   (rpn-compile p) expr))


;; The core rpn language syntax transformer. This calls parameterized
;; transformers for the different language syntax cases.

(define (quoter fn stx expr)
  (syntax-case stx ()
    ((atom) (fn #'atom expr))
    (other  (raise-syntax-error
             'arity-error
             "quoter/unquoter takes a single argument"))))

(define (combine thing expr)
  (syntax-case thing (quote quasiquote unquote)

    ;; special forms
    ((quote . a)      (quoter (rpn-quoted) #'a expr))
    ((quasiquote . a) (quoter (rpn-quasiquoted) #'a expr))
    ((unquote . a)    (quoter (rpn-function) #'a expr))
    
    ;; abstractions
    ((atoms ...)
     ((rpn-program) #'(atoms ...) expr))
    
    ;; identifiers and immediates
    (x
     (if (identifier? #'x)
         ((rpn-function)
          ((rpn-map-identifier) #'x) expr)
         ((rpn-immediate) #'x expr)))))

(define (undefined-function name expr)
  (raise-syntax-error
   #f
   "scat-undefined"
   name))

;; For local syntax. Since that leaves the current expansion, the
;; dynamic environment, installed at the entry point of the current
;; expansion, needs to be reinstalled.

(define (rpn-tx->syntax tx)
  (let ((with-rpn-context (rpn-context)))
    (lambda (stx)
      (printf "WITH: ~a\n" (object-name with-rpn-context))
      (with-rpn-context
       (lambda ()
         (tx (stx-cdr stx)))))))
    



;; FIXME: rpn-program doesnt support semantics overload (names ending in ':')


;; Parameterized core syntax transformer functions.

(define rpn-immediate   (make-parameter immediate))
(define rpn-function    (make-parameter function))

(define rpn-quoted      (make-parameter quoted))
(define rpn-quasiquoted (make-parameter quasiquoted))
(define rpn-program     (make-parameter program))

(define rpn-state       (make-parameter #'*state*))
(define rpn-lambda      (make-parameter rpn-default-lambda))

(define rpn-next        (make-parameter next))

(define rpn-map-identifier  (make-parameter (lambda (id) id)))

(define rpn-context    (make-parameter (lambda (thunk) (thunk))))
                        




;; Operate on rpn code body, processing lexical and other variables.
(define (rpn-lex-mapper fn-lex [fn-no-lex (lambda (x) x)])
  (lambda (stx-lst)
    (map
     (lambda (stx)
       (if 
        (and (identifier? stx)
             (lexical-binding? stx))
        (fn-lex stx)
        (fn-no-lex stx)))
     stx-lst)))
  
;; Scat macros that simply wrap representing expressions:

(define (make-wrapper fn)
  (lambda (code expr)
    (syntax-case code ()
      ((_ . code+)
       ((rpn-next) #'code+ (fn expr))))))

(define-sr (rpn-wrap (expr) . body)
  (make-wrapper (lambda (expr) . body)))