;; The badnop compiler word set.


(module badnop mzscheme
  (require
           ;; words
           "base.ss"       ;; load base words

           ;; utilities
           "lex.ss"        ;; string -> forth
           "forth.ss"      ;; forth -> compositional
           "ihex.ss"       ;; intel hex file stuff
           "usb.ss"        ;; usb support code
           "platform.ss"   ;; platform specific (serial port config)
           "forth.ss"      ;; symbolic forth -> compositional macro transformer
           "direct.ss"     ;; direct threaded utils
           "list-utils.ss"
           "binary-utils.ss"
           "interactive.ss"
           "tx-utils.ss"
           "assembler.ss"
           "target.ss"     ;; target dictionary object

           ;; cat
           "composite.ss"
           "primitive.ss"
           "ns-base-stx.ss"
           "ns.ss"
           "ns-utils.ss"
           "debug.ss"

           "rpn-eval.ss"
           "io-utils.ss"

           "documentation.ss"

           "config.ss"

           "rep.ss"

           "gnuplot.ss"
           
           (lib "match.ss")
           (lib "pretty.ss")
           )

  (provide badnop:)
  

  ;; The (badnop) namespace collects words from the files in the
  ;; dependencies, so we don't need to pollute the (base) namespace,
  ;; and can keep the files above free of namespace code.

  ;; (ns-new '(badnop))
  (ns-base-stx (badnop:) ((badnop)
                          (base)))  ;; delegate to (base)


  (rpn-modules "badnop.ss"  ;; debugging?
               "macro.ss")  ;; essential for compiler

  
  (snarf as-push (badnop)

   ((dict tag)       (dict-find-code dict-find-data))
   ((dict tag item)  (dict-set-data))
   ((dir component)  (load-project))         

   ((port rate) (serialconfig))
   
   ((lst)       (bin->chunks chunks->ihex bin?))
   ((lst a)     (chunk-align-bits list->table))
   ((lst a b)   (split-chunk join-nibble-list))
   ((number)    (word->string byte->string))

   ((device-descriptor) (usb-compile-device))

   ((forth-source)      (vm->native/compile))

   ((path file)  (file-in-path))
   
   ;; lex.ss
   ;; Read a file or string with forth syntax into a list.
   ((string)         (forth-string->syntax))
   ((filename path)  (forth-load-in-path))

   ;; forth.ss
   ;; Convert a list with forth syntax to macro syntax.
   ((forth)     (forth->macro.code))

   ;; interactive.ss
   ((code)    (live->prj live/vm->prj))
   ((str log) (log-line))

   ;; assembler.ss
   ((nam)     (eval-macro))  

   ((n l)     (number->chunks))
   
   )


  (compositions (badnop) badnop:

    (forth->code/macro  forth->macro.code unswons)                

                
    (words->bytes (0 8 split-chunk) map)
    (bin->ihex    bin->chunks words->bytes
                  ;; config-bits '() cons append
                  chunks->ihex)
    (print-ihex   bin->ihex (display) for-each)


    ;; Compile symbolic refs

    ;; NOTATION: words starting with colon always generate
    ;; compiled/bound (executable) code. Other words operate on lists
    ;; only.
    
    
    (:macro       'macro: rpn-compile)
    (:macro-prim  'macro-prim rpn-compile)
    (:prj         'prj: rpn-compile)
    (:live         live->prj :prj)
    (:live/vm      live/vm->prj :prj)

    ;; WARNING: this ignores macros!
    (:forth       forth->code/macro drop :macro)



    ;; read one atom from file
    (read-file-first    open-input-file dup
                        read swap close-input-port)

    ;; Load forth files in path, and compile them into executable
    ;; macros.

    (file/path->code/macro
       forth-load-in-path ;; tokenize from file tree
       forth->code/macro) ;; parse into code / macro lists

    (string->code/macro
       forth-string->syntax
       forth->code/macro)
        
    (check-bin  dup bin?
                ('assembly-failed swons throw) unless)

    (scrap-dict '()) ;; '((code . 0) (data . 0))

    ;; Update assembly object from filesystem.
    ;; asm file path -- asm+
    (asm+=file/path   :path/load! run)

    ;; Similar, but without update.
    ;; file path -- asm
    (file/path->asm   :path/load! '() swap run)

    ;; Update dictionary from filesystem + return binary code.
    ;; file path dict -- bin dict+
 
    (file/path/dict->bin/dict

           (file/path->asm) dip
           asm/dict-post
           asm/dict->bin/dict+)

    ;; ( asm dict -- binary dict+ )
    (asm/dict->bin/dict+
     
               (reverse) dip
               assemble  ;; view asm as binary code + updated dict
               (check-bin) dip)

    (asm/dict-post  (post) dip)

    ;; Compilation
    (macro-effects! '() swap run drop)  ;; run a macro for side-effects

               
    

     
    ;; debugging
    (prun/empty   '() swap run reverse print-asm)
    (pmacro       :macro prun/empty)
    (pforth       forth-string->syntax forth->macro pmacro)

    ;; print macro source
    (msee         '(macro) cons reverse ns-ref print-word)


    ;; FIXME
    
    )

  ;; COMPILATION POST PROCESSOR

  ;; some things are easier done in multiple passes. this driver will
  ;; run some macro, feeding it the assembler code, one opcode at a
  ;; time.

  (define-word compile-post (macro reverse-asm . stack)
    (let next ((in  (reverse reverse-asm))
               (s   (pack '() stack))) ;; empty asm buffer
      (if (null? in)
          s ;; done
          (let ((in+  (cdr in))
                (asm+ (cons (car in) (car s)))
                (s+   (cdr s)))

            ;; (printf "ASM: ~s\n" asm+)

            (next in+
                  (apply macro
                         (pack asm+ s+)))))))


  (compositions (badnop) badnop:

   (opti-passes ('() cons :forth compile-post) for-each)

   )

  ;; RUNTIME MACRO DEFINITIONS

  ;; This extends the compiler from a source description. The default
  ;; is compositional macros using (<name> . <body)) forms
  
  (define extend!
    (match-lambda

     ;; tagged forms
     (('scheme: expr)
      ;; (pretty-print expr)
      (parameterize
          ;; so constants can be redefined
          ((compile-enforce-module-constants #f))
        (eval expr))
      (match expr
             ;; Instantiate it's a module.
             (('module name . body)
              (dynamic-require name #f))
             (other (void))))

     ;; purely concatenative macros
     ((name () body)
      (ns-define-word! `(macro ,name)
                       (rpn-compile body 'macro:)))
     
     ;; macros with locals
     ((name formals body)
      (ns-define-word! `(macro ,name)
                       (rpn-compile `(,formals ,body)
                                    'macro-lex:)))
     ;; error
     (other
      (error 'invalid-extension-syntax "~s" other))
     
     ))

  (define (flush-dynamic-macros!)
    (ns-flush-dynamic-words! '(macro)))

  (define (warning tag . printfargs)
    (printf "~a: " tag)
    (apply printf printfargs)
    (newline))

  (snarf as-void (badnop)
   ((state filename) (save-project))         
   ((word)           (print-word print-doc))
   ((def)            (extend!))
   (()               (flush-dynamic-macros!))

   ((lst)       (plot-list))
   

   
   )
  
  




  
)