#lang scheme/base

;; Scheme macro wrapper that combines 'forth->records' from forth.ss
;; with the target word compiler from comp.ss. This is used for
;; Scheme-style 'begin' forms, both for module and toplevel namespace.

;; Note that this does NOT include bindings for any forth syntax!
;; (i.e. ':'). This is to allow the most flexibility.

(provide
 forth-begin
 forth-module-begin)

(require
 "../tools.ss"
 "../target.ss"
 "../comp.ss"   ;; target-compile and wrap/...
 "../scat.ss"
 (for-syntax
  "../tools.ss"
  (lib "pretty.ss")
  "../scat-tx.ss"
  "../macro-tx.ss"
  "../forth-tx.ss"
  scheme/base))

;; Attach semantics to the toplevel forth parser implemented by
;; 'forth->records', which maps forth code (interpreted by possible
;; forth parsing macros available in the compilation time namespace)
;; to a list of dictionary records, and collects toplevel forms using
;; a side-effect on the 'forth-toplevel-forms' parameter.

;; The following macro translates these dictionary records into
;; define-ns forms, and wraps them in a proper begin form. Forth words
;; are represented by 3 entities:

;; - a target label (eventually contains compiled code)
;; - a wrapper macro that compiles a call to the label
;; - postponed code instantiated by 'target-compile'

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

  ;; Transform different record types to a (define body) expression.
  (define (record->define/register register! record)
    (syntax-case record ()
      ((name lang loc rep)
       (syntax-case #'lang (macro)
         (macro
             (syntax-case #'name ()
               ;; Anonymous macros are not really interesting.
               ;; FIXME: maybe detect invariant: macro = identity.
               (#f #`(void))
               ;; Use macros with local exit support.
               (_ #`(redefine!-ns
                     (macro) name
                     (wrap-macro/mexit 'name loc rep)))))
         (wrap
          (syntax-case (generate-temporaries
                        '(label wrapper postponed)) ()
            ((label wrapper postponed)
             ;; collect name of postponed code to be compiled
             (register! #'postponed) 
             (syntax-case #'name ()
               ;; no name? just register postponed code
               (#f #`(define postponed rep))
               ;; else also define the macro wrapper and target code instance
               (_  #`(begin
                       (define-values
                         (label
                          wrapper
                          postponed)
                         (wrap 'name loc rep))
                       (redefine!-ns (macro) name wrapper)
                       (define-ns    (target) name label)))))))))))
    
  (define (code->defines code)
    (define words '())
    #`(begin
        #,@(map
            (lambda (record)
              (record->define/register
               (lambda (x) (push! words x))
               record))
           (forth->records
            #'wrap-macro/postponed-word
            #'wrap-macro/postponed-variable
            #'macro
            code))
        (#,register-code
         (target-compile (list #,@words)))))
    
  ;; Note: forth->records needs to run in the right environment to
  ;; define the RPN syntax!

  (parameterize
      ((forth-toplevel-forms init-forms))
    (syntax-case stx ()
      ((_ . code)
       (let* ((defs (with-macro-syntax 
                     (lambda ()
                       (code->defines #'code))))
              (topl (datum->syntax
                     stx
                     (reverse
                      (forth-toplevel-forms)))))
         #`(begin (begin #,@topl)
                  #,defs))))))



(define-syntax (forth-module-begin stx)
  (let ((module-name
         (syntax-property
          stx 'enclosing-module-name)))
    #`(#%plain-module-begin
       #,(forth-begin-tx stx
                         '((provide (all-defined-out)))
                         #'register-code))))

(define-syntax (forth-begin stx)
  (forth-begin-tx stx '() #'register-code))