#lang scheme/base

;; The 'forth-begin-tx transformer will use the data structure
;; generated by 'forth->records from forth/parser-tx.ss and combine it
;; with code from the target compiler comp.ss to provide a
;; Scheme-style toplevel 'begin form which includes 'define and
;; 'require statements next to instantiation statements.  This macro
;; can thus only be evaluated at the toplevel.

;; The function 'forth->records performs core syntax transformation,
;; translating concatenative/Forth syntax to scheme. This process is
;; guided by the rpn-xxx dynamic parameters from rpn-tx.ss as well as
;; the identifiers bound to syntax transformers visible in the
;; namespace (through 'syntax-local-value used in rpn-tx.ss). The data
;; structure returned by 'forth->records contains 4 different classes
;; of expressions: 'forth 'macro 'variable 'scheme.

;; ( I.e. the idea is that 'forth-begin does the same as 'macro: but
;;   creates top level / module level bindings, while the latter
;;   construct just creates anonymous functions. )



(provide
 forth-begin-tx
 forth-begin-tx-debug)

(require
 (for-template
  scheme/base
  "../scat.ss"
  "../comp.ss")
 scheme/pretty
 "../tools.ss"
 (lib "pretty.ss")
 "../scat-tx.ss"
 "../macro-tx.ss"
 "../forth-tx.ss"
 scheme/base)


;; GENERIC TX

(define forth-begin-tx-debug (make-parameter #f))

(define (forth-begin-tx stx init-forms register-code)

  (define (toplevel-syntax expr)
    (datum->syntax stx expr))

  ;; Transform different record types to a (define body) expression.
  (define (record->form register! record)
    (syntax-case record ()
      ((name lang loc rep)
       (syntax-case #'lang (macro scheme)
         (scheme
          (toplevel-syntax #'rep))
         (macro
             (syntax-case #'name ()
               (#f #`(void))  ;; dead macro code
               (_ #`(redefine!-ns
                     (macro) name
                     (wrap-macro/mexit 'name loc rep)))))
         (_
          (let ((wrap-macro
                 (syntax-case #'lang (variable forth)
                   (variable #'wrap-macro/postponed-variable)
                   (forth    #'wrap-macro/postponed-word))))
            (syntax-case (generate-temporaries
                          '(label wrapper postponed)) ()
              ((label wrapper postponed)
               (register! #'postponed) ;; name of postponed code to be compiled
               (syntax-case #'name ()
                 (#f #`(define postponed rep))
                 (_  #`(begin
                         (define-values
                           (label
                            wrapper
                            postponed)
                           (#,wrap-macro 'name loc rep))
                         #,(redefine!-tx (rpn-map-identifier)
                                         #'(define name wrapper))
                         #,(let ((target-id ((rpn-map-target-identifier) #'name)))
                             #`(define #,target-id label))
                         )))))))))))
    
  (define (code->toplevel-form code)
    (define words '())
    #`(begin
        #,@(map
            (lambda (record)
              (record->form
               (lambda (x) (push! words x))
               record))
           (forth->records code))
        (#,register-code
         (target-compile (list #,@words)))))

  (syntax-case stx ()
    ((_ . code)
     (let ((form
            #`(begin
                #,@(toplevel-syntax init-forms)
                #,(code->toplevel-form #'code))))
       (when (forth-begin-tx-debug)
         (pretty-print (syntax->datum form)))
       form))))