;; The bulk of the forth compiler.  Export only to (macro)
;; dictionary. The scheme functions defined here are internal.

(module compiler mzscheme
  (require "macro.ss"
           "composite.ss"
           
           "ns.ss"
           "rep.ss"
           "pattern.ss"
           "binary-utils.ss"

           "assembler.ss"
           "cat.ss"

           "rpn-eval.ss"

           "dict.ss"

           )


  ;; MISC UTIL
  

  ;; Define constants and macros at run-time. The 'check-mutable'
  ;; mechanism is there to turn off dictionary mutation.. Not sure if
  ;; it's usefull due to the way i have my forth defined atm..

  (define *mutable* #t)
  (define (check-mutable)
    (unless *mutable*
      (error 'namespace-protected)))



  

  ;; PRIMITIVE MACROS

  ;; Some of these (ending with '>asm') used to be writer macros. i
  ;; took out those because they are too confusing.
  
  (compositions
   (macro) macro-prim:
   
;   (m>load-usb symbol->pathfile read-file-first usb-compile-device
;               forth-list->program run/s)

;   (m>quoter    register-quoting-parser!)


   ;; COMPILATION STACK
   
   ;; During compilation, the CAT data stack is the compile stack,
   ;; used for nested control structs and other macros referring to
   ;; symbols.

   ;; The idea is to make the set of operations complete enough so
   ;; simple recursive macros can be used to extend the compiler for
   ;; almost any operation, using the interaction between the
   ;; compilation stack (peephole optimizer) and the macro/meta stack.
   
   (m-dup        dup)
   (m-drop       drop)
   (m-swap       swap)
   (m-over       over)
   (m-2dup       2dup)

   
   ;; platform dependent: m>jump m>call
   

   ;; FOR / NEXT backtracking

   ;; (fail         #f require)
   (m-amb-run/s  amb-run/s) ;; m1 m2 -- 

   ;; FIXME: find the real pattern here and abstract it. this is a bit
   ;; of a mess.
   
   ;; this will fail if it finds a dup after the label
   (constraint:label-nodup
    dup state swap         
    (;; ( label asm -- )
     'dummy-sentinel swons  
     rewind-asm 
     car ;; '[dup] equal?
     dup '[dup] equal? swap
         '[save] equal? or not) dip
                                             
         ;; ok?
         swap require)


   )




  ;; CODE GENERATOR

  (define (macro-find/false x)
    (ns-ref `(macro ,x) #f))

  (asm-transforms (macro)


   ;; This is here to trap faulty macro arguments. The bar | symbol is
   ;; a reserved word used only for argument lists, and should never
   ;; occur in code.
                  
   ((\|) ([qw (error 'macro-argument-error)]))

                  
   ;; attempt to implement all parsing words operating on the literal
   ;; stack instead of the data stack (which is reserved for control data)

   ;; this is really just a typed concatenative language.


   (([qw a]  >m)      ((insert (list (macro-prim: 'a)))))
   (([cw a]  word>m)  ((insert (list (macro-prim: 'a)))))

   (([qw a]  execute) ([cw a]))
   ((execute)         ([cw 'runtime-execute]))
     
   (([cw a]  exit)    ([jw a]))
   
   (([dw a]  dw>)     ([qw a]))

   (([label l] label?)  ([label l] [qw #t]))
   ((label?)            ([qw #f]))

   (([qw l] label)     ([label l]))
   
   ((sym)              ([qw (make-label)]))

   
   ((stub)     ([stub]))    ;; peephole optimizer fence
   ((save)     ([save]))
   
   ;; This has a bit of an awkward syntax due its generality. The
   ;; 'asm-transformers' syntax serves the greater good of the pattern
   ;; matching assemblers (one level of quoting)..

   (([,rator . rands] opcode)
    ((insert `([,rator ,@rands] [qw ,rator]))))

   ;; COMPILE is the same as execute for target words, but can also
   ;; invoke a macro.
   
   (([qw w] compile)
    ((insert
      (cond
       ((word? w) `(,w))
       ((symbol? w)
        (let ((m (macro-find/false w)))
          (if m
              `(,m)               
              `([cw ,w]))))
       (else
        `([qw ,w]))))))
            
   ;; FIXME: write this in terms of the previous.
   
   ;; If a macro is found in the macro dictionary, run the macro, else
   ;; pass the name to another macro. This is used in VM -> native
   ;; forth mapping.
   (([qw word-name] [qw default-semantics-name] macro/default)
    ((insert
      (if (macro-find/false word-name)
          `(,(macro-prim: '(word-name) :macro run/s))
          `([qw ,word-name]
            ,(macro-prim: '(default-semantics-name) :macro run/s))))))

             
   
   ;; Quoted parser backends.                     

   (([qw name] *:)                 ([label name]))
   (([qw name] [qw size] buffer)   ([variable name] [allot 'data size]))
   (([qw thing] |*'|)              ([qw thing]))
                    
   ;; 'string' actually just interprets its SYMBOL argument as
   ;; bytes, replacing underscores by spaces. symbol->bytecomma
   ;; converts a symbol to a comma separated list of numbers, which
   ;; we compile and run/s here.
   
   (([qw symbol] *fsymbol)
    ((insert
      (list
       (macro-prim:
        'symbol symbol->bytecomma :macro run/s)))))


   ;; RAM
   (([qw realm] [qw n] allot) ([allot realm n]))
           


   ;; Higher order macros.
   (([qw a] [qw b] ifte)
    ((insert
      (list
       (macro: if   'a compile
               else 'b compile
               then)))))


   ;; Dictionary lookup.
   ;; (([qw tag] [qw dict] dict-find) ([qw (dict-find dict tag)]))

   ;; Name mangling.
   (([qw method] [qw class] [qw dash] prefix)
    ([qw (string->symbol
          (format "~a~a~a" class dash method))]))
   
   )



  ;; HIGLEVEL MACROS

  (compositions
   (macro) macro:

   ;; important note: all the archs (planned to be) supported in brood
   ;; are register machines, so 'literal' is always SAVE (which
   ;; reserves a cell on the data stack in the most efficient way,
   ;; mostly just DUP) followed by LDTOP (load top register).

   ;; (for a forth machines, brood would not need a peephole
   ;; optimizer.. the whole point of brood is to make the virtual
   ;; forth machine emulation happen with a good assembler mapping)
   
   ;; control flow

   ;; or-goto \ ? word --
   ;; equivalent to "swap if execute ; then drop"
   ;; aka JNZ
   
   (jump      execute exit)       ;; \ name --   (start of branch)
   ;(comefrom label)              ;; \ name --   (end of branch)
   
   (if      sym dup >m or-jump)
   (else    sym dup >m jump m-swap then)
   (then    m> label) 

   (begin   sym dup >m label)
   (again   m> jump)

   (do      begin)
   (while   if)
   (repeat  m-swap again then)
   
   (until   not while repeat)

   (route   _route stub)
   (route/e _route/e stub)


   ;; one with drop .. save wrapped around it. this generates better
   ;; code for loops that do 'read modify write'. platform specific
   ;; needs to define for0 ... next0
   (for1  dup for0 drop)
   (next1 save next0 drop)


   ;; amb-compile will non-deterministically compile (execute) one of
   ;; the two quoted macros. each macro quotes a macro implementing
   ;; its 'next' behavirour (next just executes macro from m>).

   (for   (for0 (constraint:label-nodup
                 next0) >m)
          (for1 (next1) >m)
          amb-compile)

   (amb-compile   swap >m >m m-amb-run/s)

   (next  m> compile)


   ;; Namespaces
   (pc     ' |.| prefix compile)  ;; method object --



   ;; FIXME: make quack read this correctly
   (|;|      exit)

   )

  
)