(module comp mzscheme

  (require (lib "match.ss")
           "cat.ss"
           "ns.ss"
           "composite.ss"
           
           "state.ss"
           "asm.ss"
           "forth.ss"
           "parse.ss"
           "writer.ss"
           "pattern.ss"
           "binary-utils.ss"
           "list-utils.ss"
           "comp-utils.ss"
           "usb.ss")


  (provide (all-defined))




  (state-stx  macro: (macro) (base))
  

  ;; compilation utils
  ;; ASMBUF -> ASMBUF
  (compositions
   (state-stx (macro)
              (macro) (base))

   (op>asm    cons reverse >asm)
   )






  

  ;; POSTPONE behaviour: create a compiler word from code or data
  ;; object. This refers to the 'c>' and 'c>word' macros defined
  ;; elsewhere.

  ;; We'll pack the whole semantics in a single word.

  (define code-compiler
    (let ((promise (delay (ns-ref '(macro c>word)))))
      (lambda (word-name)
        (let ((c>word (force promise))  ;; get compiler macro
              (word   (lambda (compilation . stack)
                        (pack compilation word stack))))
                      
          (macro: word c>word)))))
          

  (define (data-compiler name) _)





  
  (define-syntax macro-stx
    (syntax-rules ()
      ((_ anon-fn: (ns ...))
       (begin
         (macro-compile COMPILE (ns ...))
         (rpn-transformer anon-fn: COMPILE)))))
  
  

;; shared code for forth compilers
;; contains:
;;
;; - support for assembler constants
;;
;; - forth code parser
;;
;; - compiler (macro) dictionary hash. organised in separate classes
;;   with different access patterns.
;;
;;   * general purpose cat UTILITIES, used in body code
;;   * asm STATE macros: access to asm-buffer abstract state
;;   * WRITER macros: produce chunks of asm code
;;   * RECURSIVE macros: written in terms of other macros
;;   * flat asm PATTERN MATCHING macros = optimizing compiler

  


  ;; the CAT semantics for forth literals, highlevel forth words
  ;; (call/jump) and macros (which default to highlevel forth words).
  
;;   (define-syntax macro-1-arg->cs
;;     (syntax-rules ()
;;       ((_ macroname)
;;        (let ((catword (delay (macro-find 'macroname))))
;;          (lambda (argument)
;;            (lambda (asm . stack)
;;              (apply (force catword)
;;                     (pack asm argument stack))))))))

;;   (define cs-forth-literal (macro-1-arg->cs c>))
;;   (define cs-forth-word (macro-1-arg->cs c>word))

  ;; FIXME: still not late enough?
  ;; (define (cs-macro-find sym)
;;     (word->procedure (macro-find sym)))

  ;; this is the default for the forth parser: map anything to a CAT
  ;; word that will compile it to the asm buffer (asm . stack) -> (asm . stack)
  
 ;;  (define (postpone thing)
;;     (atom->word thing
;;                 (if (symbol? thing)
;;                     cs-macro-find
;;                     cs-forth-literal)))
  
  ;; the default semantics of a forth word is the postponed-word
  ;; primitive bound to a symbol in a 'word' structure
  (define (macro-find-default thing)
    ;; (printf "default semantics: ~a~n" thing)
    (atom->word thing cs-forth-word))
  
  (define-symbol-table
    macro-register!
    macro-find/false
    (lambda (thing) #f))
  
  (define (macro-find thing)
    (or (macro-find/false thing)
        (macro-find-default thing)))
  

  ;; these need to be overridden
  (need-cat-words macro-register! '(c>word c>))
  
  (define-word macro-list stack
    (cons (symbol-table-words 'macro-find) stack))
  
  ;; same class, but defined in scheme.

  ;; register a constant as a macro. if it's a single value constant,
  ;; then register it as an assembly constant.

  (define (constant/recursive-register! name body)
    ((if (= 1 (length body))
         constant-register!
         recursive-register!) name body))
    
  (define-word def-constant! (name body . stack)
    (constant/recursive-register! name body)
    stack)

  ;; variables need to be treated as literals instead of function calls
  (define-word def-variable! (name . stack)
    (macro-register! name
                     (atom->word name
                                 cs-forth-literal))
    stack)

  (define-word def-macro! (name body . stack)

    ;; (display name) (display body) (newline)
    (recursive-register! name body)
    stack)

  (define-word def-parser! (name body . stack)
    (forth-parse-symbolic-expand-register! name body)
    stack)

  (define-word make-label stack (pack (make-label) stack))


             


  (compositions cat!
   (opti-passes (() cons forth->program compile-post) for-each)
   (bad-instruction (() cons) dip swons throw) ; opcode error --
   
   (macro   macro->program)) ;; compile symbolic code to macro cat program, no parsing words


  
  ;; *** CODE GENERATOR MACROS ***
  
  ;; passing control to any other macro from a pattern matching macro
  ;; can be done by leaving an 'egg' word in the assembler code:

  (define (lit x)   `(,(atom->word x cs-forth-literal)))
  (define (macro x) `(,(atom->word x cs-macro-find)))


  ;; *** FORTH PARSER ***

  ;; there are 2 levels:
  ;;   - simple forth:  in simple code, each word's behaviour is independent
  ;;   - full forth:    simple + parsing words like ':'

  ;; the idea is to not use full forth if it's not necessary, like in
  ;; macro definitions.

  ;; use the shared forth parser with compiler's literal and macro
  ;; lookup plugs

  ;; FIXME: the rest is in forth.ss
  
;;   (define (macro->program src)
;;     (pure-forth->program  ;; syntax is compositional forth
;;      postpone             ;; we provide semantics
;;      (run-parsers
;;       (lambda (sym)
;;         (if (eq? '|'| sym)
;;             (forth-parse-find sym) #f))
;;       src)))              ;; only quote (FIXME: is there a real reason here??)


;;   (define (forth->program src)
;;     (pure-forth->program  ;; syntax is compositional forth
;;      postpone             ;; we provide semantics
;;      (run-parsers
;;       forth-parse-find    ;; use generic forth parser semantics as preprocesor
;;       src)))
  
  (cat-snarfs
   ((x)   (forth->program macro->program register-quoting-parser!)))
  

  ;; macros use simple forth
  (define (recursive-register! name body)
    ;; (printf "register ~s\n" name)
    (macro-register! name
                     (subroutine->word macro->program body)))
  


  ;; *** CONSTANTS ***




  (define-syntax constants
    (syntax-rules ()
      ((_ defs ...)
       (compositions constant-register! defs ...))))


  (compositions
   cat!

   )
  

  ;; *** MACROS ***


  (define asm-buffer-macro-register!
   (make-composer    macro-register! ;; forth compiler macro name space
                     state-parse     ;; using state binding parser
                asm-buffer-find))    ;; with words from asm-buffer object

   



  
  )