#lang scheme/base
(require "../"
         (for-syntax scheme/base

;; 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 ...)
         (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
             code ...))

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

 (define (with-mode def-word register! wrap)
    (lambda (name)
      #`(#,def-word #,register! #,wrap #,name rpn-lambda))))

 ;; ':' takes semantics from last entry.
 (define (last-mode register! forthword wrapword macroword wrapmacro)
    (lambda (d) ;; get-compile
      (let ((entry (d-last d)))
         (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))
    (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)))
     ((forth) (:forth #f))     ;; (*)
     ((macro) (:macro #f)))

    (define-syntax-rule (forth-begin . code)
       (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
               (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/")
(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
               (lambda (w d k)
                 (k (w-cdr w)
                     (datum->syntax (w-car w) ;; context needs to come from module
                                    '(provide (all-defined-out)))

;; Forth parsers.

;; ((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,|))