;; This contains the core syntax transformers procedures for rpn ->
;; scheme mapping. This contains SYNTAX ONLY. Global symbol semantics
;; is handled elsewhere (see composite.ss).

(module rpn-tx mzscheme

  (require "list-utils.ss"
           "tx-utils.ss")

  (require-for-template mzscheme
                        "rpn-runtime.ss"
                        "rep.ss")
  
  (provide (all-defined))
           

  ;; DEFAULT COMPILATION

  ;; All routines act 'cons' on a current object and rest expression,
  ;; and thus can be folded. In fact, 'represent' is a fold over
  ;; source code.


  ;; The default data and code behaviours: immediates are just copied
  ;; to the top of the data stack, and code is applied to the
  ;; stack. The 'expr' here is either a formal parameter 'stack' from
  ;; a lambda expression (lambda stack ...), or a nested structure of
  ;; any of the typed compilation procedures below.
  
  (define (immediate c object expr)  #`(cons #,object #,expr))
  (define (function  c object expr)   #`(apply #,object #,expr))

  ;; Lexical variables are interpreted as code.

  (define lexical function)
  
  ;; In addition to lexical identifiers, module-imported identifiers
  ;; can be matched too. If an identifier 'rpn.foo' is bound in the
  ;; current module context, it will bind occurances of 'foo' in the
  ;; source code. Currently this behaviour is only implemented for
  ;; functions, not constants (quotations).
  
  (define module-imported function)

  (define rpn-prefix #'rpn.)

  ;; The default non-lexical and non-module-imported compiler doesn't
  ;; bind to any external namespace. You need to override this to do
  ;; anything useful.

  (define (global . args) (error 'no-global-namespace-defined))
  

  
  ;; Quote has special behaviour when the quoted expression contains
  ;; symbols with lexical bindings: then they will assume the lexical
  ;; values (using unquote). A quote expression thus needs to be
  ;; implemented by scheme quasiquote.

  (define (quoted c object expr)
    
    (define (lex/uq stx)
      (syntax-case stx ()
        ((car . cdr) 
         #`(#,(lex/uq #'car) . #,(lex/uq #'cdr)))
        (atom
         (if (and (identifier? #'atom)
                  (lexical-binding? #'atom))
             #'(unquote atom)
             #'atom))))
    
    ((c-immediate c) c
     #`(quasiquote #,(lex/uq object))
     expr))

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


  (define (quasiquoted c object expr)

    (define (uq stx)
      (syntax-case stx (unquote)
        ((unquote expr)
         #`(unquote
            #,((c-represent c) c #'expr)))  ;; program?
        ((car . cdr)
         #`(#,(uq #'car) . #,(uq #'cdr)))
        (atom
         #'atom)))

    ((c-immediate c) c
     #`(quasiquote #,(uq object))
     expr))
    
  

  

  ;; Programs are lists occurring in a program list. They are the
  ;; anonymous abstraction feature (lambda). Note that all functions
  ;; are unary: stack -> stack. The default meaning of a program list
  ;; is to push the (compiled) function on the stack.


  ;; We allow the semantics of quoted programs to be overridden using
  ;; symbol names ending with ':' which will be collected by the
  ;; scheme expander.

  (define (ends-in? symbol char)
    (eq? char
         (car
          (reverse
           (string->list
            (symbol->string symbol))))))
  
  (define (scheme? program)
    (let ((l (->datum program)))
      (and (not (null? l))
           (let ((head (car l)))
             (and (symbol? head)
                  (ends-in? head #\:))))))

  

  (define (program c p expr)
    ((c-immediate c) c
     (if (scheme? p)
         p                      ;; leave it for the scheme expander
         ((c-represent c) c p)) ;; use default expander

     expr))

  (define (language-name c) #f) ;; needs to be overridden


  ;; DISPATCH

  ;; This implements the parsing for the basic syntactic elements.
  ;; The dispatcher can be extended using a 'c' object containing the
  ;; methods for the different syntactic cases.

  ;; In addition to foldable procedures, the 'c' object also contains
  ;; a 'represent' method, which is used for recursively compiling
  ;; quoted subprograms.

  (define-struct c
    (represent
     language-name
     immediate lexical global program
     quoted quasiquoted module-imported)) 

  (define (proto-c)
    (make-c
     represent
     language-name
     immediate lexical global program
     quoted quasiquoted module-imported))


  ;; REPRESENTATION

  ;; All rpn functions are represented as a nested scheme
  ;; expression. The dispatcher above is used as the argument to a
  ;; fold over a source list.
  
  (define (represent c source)
    #`(make-word
       '#,((c-language-name c) c)
       (quote #,source)
       (lambda stack
         #,(fold (lambda (o e)
                   (dispatch c o e))
                 #'stack
                 (syntax->list source)))))
  

  ;; The '|' symbol is special. If it is present in a code list, the
  ;; symbols on the left are interpreted as formal arguments, taken
  ;; from the stack.

;;   (define (bar? x)
;;     (eq? '\| (->datum x)))
  
;;   (define (represent-lambda c source)
;;     (let-values
;;         (((formals pure-source)
;;           (split-at-predicate bar? (syntax->list source))))
;;       #`(make-word
;;          '#,((c-language-name c) c)
;;          (quote #,source)
;;          (lambda
;;              #,(if (null? formals) #'stack
;;                    #`(#,@(reverse formals) . stack))
;;            #,(fold (lambda (o e)
;;                      (dispatch c o e))
;;                    #'stack
;;                    pure-source)))))

  (define (dispatch c thing expr)
    
    (syntax-case thing (quote quasiquote)

      ;; special forms
      ((quote . qargs)
       (syntax-case #'qargs ()
         ((atom)    ((c-quoted c) c #'atom expr))
         (other     (raise-syntax-error
                     'invalid-quote-form
                     "quote takes a single argument"
                     #'other))))

      ((quasiquote . qargs)
       (syntax-case #'qargs ()
         ((atom)    ((c-quasiquoted c) c #'atom expr))
         (other     (raise-syntax-error
                     'invalid-quasiquote-form
                     "quasiquote takes a single argument"
                     #'other))))

      ;; abstractions
      ((atoms ...)
       ((c-program c) c #'(atoms ...) expr))
          
      ;; leaf nodes
      (x
       (let ((->
              (lambda (method obj)
                ((method c) c obj expr))))

         (cond
          ((not (identifier? #'x)) (-> c-immediate #'x))
          ((lexical-binding? #'x)  (-> c-lexical #'x))
          (else
           (let ((pre (prefix rpn-prefix #'x)))
             (if (module-binding? pre)
                 (-> c-module-imported pre)
                 (-> c-global #'x)))))))))


  ;; BASE SYNTAX + NS

  ;; A transformer for run time name binding using force/delay.
  ;; 'find' refers to a closure used for name resolution. It needs to
  ;; return an executable representation that can be applied to the
  ;; stack.
  
  (define (ns-base-rpn code find language-names)
    
    (define (_name c) (first language-names))
    
    (define (_global c object expr)
      #`(apply/force
         (delay (#,find (quote #,object)))
         #,expr))

    ;; Create compiler object for global symbol lookup.
    (define c (proto-c))
    (set-c-global!        c _global)
    (set-c-language-name! c _name)

    (represent c code))


  ;; STATE SYNTAX + NS

  ;; Similar, but using a 'hidden' top of stack element which can
  ;; contain arbitrary state to be threaded through
  ;; computations. 'find' needs to do lifting of the functions it
  ;; returns. We'll lift the immediates here.
  
  (define (ns-state-rpn code find language-names)

    (define (_name c)      (first language-names))
    (define (_base_name c) (second language-names))
    
    (define (_global c object expr)
      #`(apply/force
         (delay (#,find (quote #,object) 'state))
         #,expr))

    (define (_immediate c object expr)
      #`(state-immediate #,object #,expr))


    ;; Quoted programs are not bound to the state dictionary. This is
    ;; because words like 'run' and 'ifte' are lifted, so they cannot
    ;; pass on state. Overall it seems to me that this is the right
    ;; thing to do: if state needs to be passed on, a different syntax
    ;; needs to be used for quoting programs, and the run/s word can be
    ;; used for execution.

    ;; To implement this behaviour, the 'represent' method needs to be
    ;; overwritten so it compiles programs using the base semantics,
    ;; and the corresponding 'global' method needs to be adjusted to
    ;; notify 'find' we're looking for a base symbol only.
    
    (define (_base-represent c list)
      (represent base-c list))

    (define (_base-global c object expr)
      #`(apply/force
         (delay (#,find (quote #,object) 'base))
         #,expr))
                
    
    (define c (proto-c))
    (define base-c (proto-c))
    
    ;; Main compiler object
    (set-c-represent!     c _base-represent)
    (set-c-immediate!     c _immediate)
    (set-c-global!        c _global)
    (set-c-language-name! c _name)

    ;; Compiler object for quoted code
    (set-c-global!        base-c _base-global)
    (set-c-language-name! base-c _base_name)
    

    (represent c code))
  
  
  
  )