;; Utilities for the direct threaded interpreter VM

;; This translates DTC code in compile or interactive mode into the
;; corresponding syntax for the underlying forth or interaction system.

;; This is PURE SYNTAX. The words are not interpreted.

;; Symbols are mapped to forth names by prepending them with an
;; underscore. It's a bit crude, but allows easy merging of name
;; spaces without introducing a load of red tape in the lowlevel
;; forth.

(module direct mzscheme

  (require "primitive.ss"
           "stx-stream.ss"
           "dict.ss"
           "binary-utils.ss"
           "list-utils.ss"
           "cat.ss"           ;; need cat before registering
           "tx-utils.ss"
           "ns.ss"
           "forth.ss"
           )

  (provide vm->native/compile
           live/vm->prj)

  
  (define (underscore stx)
    (->syntax
     stx
     (string->symbol
      (string-append
       "_"
       (symbol->string (->datum stx))))))


  (define (vm->native/compile code)

    (define default
      (predicates->parsers
       (symbol?      ((w)       (|'| #,(underscore #'w)
                                 |'| _compile macro/default)))
       (number?      ((n)       (n _literal)))))

    (apply-parsers-ns/default
     '(compile-vm) default code))

  
  (named-parsers (compile-vm)
       
   (0cmd         ((w)       (w)))
   (|:|          ((_ name)  (: #,(underscore #'name) enter)))
   (|;|          ((_)       (_exit))))
       
  (named-parser-clones (compile-vm)
   (0cmd pa clear))
    


  ;; FIXME abstract out ns/default thingy
  
  (define (live/vm->prj code)

    (define default
      (predicates->parsers
       (symbol?   ((w)   ('#,(underscore #'w) tf
                          _tlit 'dtc tfind texec/w)))
       (number?   ((n)   (n _tlit)))))
    
    (apply-parsers-ns/default
     '(live-vm) default code))
  
    

  ;; FIXME: find a way to extend the other live commands.
  ;; map these to their '_' counterpart

  ;; FIXME: commands that take no args can be simply mapped.
  ;;(define (_command? x)  (element-of x '(ts tss tsx cold ping)))

  (named-parsers (live-vm)

   (0cmd      ((w)   (w))) ;; just use same as native
   (_0cmd     ((w)   (#,(underscore #'w)))) ;; special

   (1cmd      ((w)   (_t> #,(underscore #'w)))))

  
  (named-parser-clones (live-vm)
                       
   (0cmd   commit clear pa ppa cold ping)
   (_0cmd  ts tss tsx)
   (1cmd   p ps px kb))


  

)