#lang scheme/base
(require "../rpn.ss"
         "../macro.ss"
         "../tools.ss"
         (for-syntax scheme/base
                     "../forth/lexer-tx.ss"
                     "../rpn.ss"
                     "../forth/forth-tx.ss"))

;; Toplevel forms for dictionary construction and compilation for the
;; Staapl macro forth.

;; These forms assume particular namespace organization:
;;   * macro   op transformer namespace
;;   * target  instantiated op lists
;;   * inline  postponed instantiation macros for target words
;;
;; The dictionary is in a special format: (define register! wrap name compile code ...)
;;   - define    = define-macro or define-forth
;;   - register! = called for each inline macro (used for instantiation)
;;   - wrap      = wrapper functions provided by compiler
;;   - name      = word name
;;   - compile   = semantics of (code ...)

(provide (all-defined-out))


(define-syntax macro-word
  (syntax-rules ()
    ((_ _ _ #f _ . code) (word-trap-anon . code)) ;; mode marker
    ((_ register! wrap name compile code ...)
     (ns (macro)
         (define name
           (wrap 'name #f (compile code ...)))))))

(define-syntax-rule (word-trap-anon) (begin))


(define-syntax define/false
  (syntax-rules ()
    ((_ _ #f _)   (begin)) ;; don't define anonymous words
    ((_ (n ...) name value) (ns (n ...) (define name value)))))

(define-syntax forth-word
  (syntax-rules ()
    ((_ register! wrap name compile code ...)
     (begin
       (define-values
         (label wrapper inline)
         (wrap 'name #f (compile code ...)))
       (define/false (target) name label)
       (define/false (macro)  name wrapper)
       (define/false (inline) name inline)
       (register! inline)))))

;; Toplevel forms.

;; Similar to 'macro: but for a toplevel form.  Initialize dictionary
;; in 'forth' mode, but make sure the first line is invalid.
(define-syntax-rule (forth-begin/init init code ...)
  (rpn-parse (begin
               (macro)     
               scat-apply  
               macro-push
               macro-push
               macro:
               init)
             code ...))


(define-syntax-rule (provide-words w ...)
  (provide
   (ns-out (target) w) ...
   (ns-out (macro) w) ...
   (ns-out (inline) w) ...))

(begin-for-syntax
 (define (with-mode def-word register! wrap)
   (make-rpn-forth-definition-transformer
    (lambda (name)
      #`(#,def-word #,register! #,wrap #,name rpn-lambda))))

 ;; ':' takes semantics from last entry.
 (define (last-mode register! forthword wrapword macroword wrapmacro)
   (make-rpn-same-definition-transformer
    (lambda (d) ;; get-compile
      (let ((entry (d-last d)))
        (rpn-make-header->compile
         (lambda (name)
           (syntax-case entry (macro-word)
             ((macro-word . _) #`(#,macroword #,register! #,wrapmacro #,name rpn-lambda))
             (else             #`(#,forthword #,register! #,wrapword #,name rpn-lambda)))))))))

 (define (stx->path it)
   (let* ((it (syntax->datum it))
          (it (if (symbol? it) (symbol->string it) it)))
     (string->path it)))


)


;; Primitive parsing word transformers coupled to compilation forms.
(define-syntax-rule (define-forth
                      (forth-begin forth macro : :macro :forth :variable)
                      (reg wrap-macro wrap-word wrap-variable))
  (begin
    (ns (macro) (define-syntax :macro    (with-mode #'macro-word #'reg #'wrap-macro)))
    (ns (macro) (define-syntax :forth    (with-mode #'forth-word #'reg #'wrap-word)))
    (ns (macro) (define-syntax :variable (with-mode #'forth-word #'reg #'wrap-variable)))
    (ns (macro) (define-syntax :         (last-mode #'reg
                                                    #'forth-word #'wrap-word
                                                    #'macro-word #'wrap-macro)))
    (prefix-parsers
     (macro)
     ((forth) (:forth #f))     ;; (*)
     ((macro) (:macro #f)))

    (define-syntax-rule (forth-begin . code)
      (forth-begin-empty
       (forth-word reg wrap-word #f rpn-lambda) ;; start in Forth mode.
       . code))))
    
     
;; (*) Mode switchers are implemented in terms of anonymous code It
;; doesn't result in namespace bindings but in Forth mode the
;; postponed code is passed to register!  This is mainly there to
;; support compiler/assembler directives like 'org.  Note that
;; anonymous macro words don't make sense.

(ns (macro) (define-syntax load  ;; nested files
              (make-rpn-include-transformer
               file->forth-syntax
               stx->path
               forth-path
               (lambda (filename) ;; logger
                 (printf " include ~s\n" (path->string filename))))))


;; Recursive expansion.  This is necessary to make sure 'require
;; and 'define-syntax forms introduce transformer bindings before
;; continuing parsing.
(ns (macro) (define-syntax expand (make-rpn-expand-transformer #'forth-begin)))

;; Inline s-expressions.  Note that if your current lexer allows, once
;; inside this construct ordinary s-expressions can be used.
(ns (macro) (define-syntax |{| rpn-curly-brace-transformer))

;; Ignore the '#lang syntax
(ns (macro) (define-syntax |#lang|
              (rpn-syntax-rules (planet)
                                ((_ planet spec) ())
                                ((_ spec) ()))))

    
;; Local lexical variables.
(require scheme/match)
(require "../comp/state.ss")
(define (macro-pop state n)
  (let-values (((state+ popped) (state-pop state n (ns (op ? qw)))))
    (apply values (cons state+ popped))))
  
(define-syntax-rule (macro-locals . a)
  (rpn-let-locals ((macro) macro: macro-pop) . a))
(ns (macro) (define-syntax \| (make-rpn-locals-transformer #'macro-locals)))
(ns (macro) (define-syntax path (make-rpn-path-transformer stx->path)))


;; Since there are no strings, how should this work?  Maybe use two
;; words: one that takes filenames directly and another one that uses
;; scheme symbols.
(define-syntax (require-sym stx)
  (syntax-case stx ()
    ((_ sym)
     #`(require #,(path->string (stx->path #'sym))))))
  

(ns (macro) (define-syntax provide-all
              (make-rpn-transformer
               (lambda (w d k)
                 (k (w-cdr w)
                    (rpn-compile-toplevel
                     (datum->syntax (w-car w) ;; context needs to come from module
                                    '(provide (all-defined-out)))
                     d))))))

;; Forth parsers.

(prefix-parsers
 (macro)
;; ((forth)       (|{| forth-word |}|))  ;; compiler macros used as stubs to switch mode.
;; ((macro)       (|{| macro-word |}|))
 ((require m)   (|{| require-sym m |}| expand))          ;; expand after require
 ((planet m)    (|{| require (planet m) |}| expand))
 ((provide w)   (|{| provide-words w |}|))
;; ((provide-all) (|{| provide (all-defined-out) |}|))

 ((variable n)  (:variable n 1 allot))  ;; FIXME: needs parameterization


 ;;   ((|`| name)       ('name))
 ;;   ((|'| name)       (',(ns (macro) name)))
 ;;   ((variable name)  (create name 1 allot))
 ;;   ((2variable name) (create name 2 allot))
 ;;   ((vector name)    (2varable name))
 ;;   ((declare name)   (:macro name 'name undefined |;|))
 ;;   ((parameter name) (:macro name ,(make-constant 'name) |;|))
 ;;   ((string name)    (',(symbol->string 'name)))
 
 ;; Trouble with the word 'f->' being defined later...
 ;; ((fstring name)   (f-> string name |string,|))
 
 )